smumps_sol_es.F File Reference

Go to the source code of this file.

Modules
module	smumps_sol_es

Functions/Subroutines
subroutine, public	smumps_sol_es::smumps_sol_es_init (size_of_block_arg, keep201)
subroutine, public	smumps_sol_es::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)
subroutine, public	smumps_sol_es::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)
subroutine, public	smumps_sol_es::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)
subroutine, public	smumps_sol_es::smumps_propagate_rhs_bounds (pruned_leaves, nb_pruned_leaves, step, n, pruned_sons, dad, rhs_bounds, nsteps, myid, comm, keep485, iw, liw, ptrist, kixsz, ooc_fct_loc, phase, ldlt, k38)
integer(8) function	smumps_sol_es::smumps_local_factor_size (iw, liw, ptr, phase, ldlt, is_root)
integer(8) function	smumps_sol_es::smumps_local_factor_size_blr (iw, liw, ptr, lrstatus, iwhandler, phase, ldlt, is_root)
subroutine, public	smumps_sol_es::smumps_tree_prun_nodes_stats (myid, n, keep28, keep201, fr_fact, step, pruned_list, nb_prun_nodes, ooc_fct_type_loc)
subroutine, public	smumps_sol_es::smumps_chain_prun_nodes_stats (myid, n, keep28, keep201, keep485, fr_fact, step, pruned_list, nb_prun_nodes, ooc_fct_type_loc)
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)
subroutine	smumps_permute_rhs_am1 (perm_strat, sym_perm, irhs_ptr, nhrs, perm_rhs, sizeperm, ierr)
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)

Variables
integer(8), dimension(:,:), pointer	smumps_sol_es::size_of_block
integer(8), public	smumps_sol_es::pruned_size_loaded

Function/Subroutine Documentation

smumps_interleave_rhs_am1()

subroutine smumps_interleave_rhs_am1	(	integer, dimension(size_perm), intent(inout)	perm_rhs,
		integer, intent(in)	size_perm,
		integer, dimension(size_iptr_working), intent(in)	iptr_working,
		integer, intent(in)	size_iptr_working,
		integer, dimension(size_working), intent(in)	working,
		integer, intent(in)	size_working,
		integer, dimension(n+1), intent(in)	irhs_ptr,
		integer, dimension(n), intent(in)	step,
		integer, dimension(n), intent(in)	sym_perm,
		integer, intent(in)	n,
		integer, intent(in)	nbrhs,
		integer, dimension(nsteps), intent(in)	procnode,
		integer, intent(in)	nsteps,
		integer, intent(in)	slavef,
		integer, intent(in)	keep199,
		logical, intent(in)	behaviour_l0,
		logical, intent(in)	reorder,
		integer, intent(in)	n_select,
		logical, intent(in)	prokg,
		integer, intent(in)	mpg )

Definition at line 612 of file smumps_sol_es.F.

      IMPLICIT NONE
      INTEGER, INTENT(IN) ::  SIZE_PERM,
     &                        SIZE_IPTR_WORKING,
     &                        IPTR_WORKING(SIZE_IPTR_WORKING),
     &                        SIZE_WORKING,
     &                        WORKING(SIZE_WORKING),
     &                        N,
     &                        IRHS_PTR(N+1),
     &                        STEP(N),
     &                        SYM_PERM(N),
     &                        NBRHS,
     &                        NSTEPS,
     &                        PROCNODE(NSTEPS),
     &                        SLAVEF, KEEP199,
     &                        n_select, MPG
      LOGICAL, INTENT(IN) :: behaviour_L0,
     &                        reorder, PROKG
      INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM)
      INTEGER :: I, J, K,
     &           entry,            
     &           node,             
     &           SIZE_PERM_WORKING,
     &           NB_NON_EMPTY,     
     &           to_be_found,      
     &           posintmprhs,      
     &           selected,         
     &           local_selected,   
     &           current_proc,     
     &           NPROCS,           
     &           n_pass,           
     &           pass,             
     &           nblocks,          
     &           n_select_loc,     
     &           IERR
      INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS,    
     &                                      PTR_PROCS,  
     &                                      LOAD_PROCS,  
     &                                      IPTR_PERM_WORKING,
     &                                      PERM_WORKING,
     &                                      MYTYPENODE,
     &                                      PERM_PO
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED
      LOGICAL :: allow_above_L0
      INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH
      nprocs = size_iptr_working - 1
      ALLOCATE(tmp_rhs(size_perm),
     &         ptr_procs(nprocs),
     &         load_procs(nprocs),
     &         used(size_perm),
     &         iptr_perm_working(nprocs+1),
     &         mytypenode(nsteps),
     &         stat=ierr)
      IF(ierr.GT.0) THEN
        WRITE(*,*)'Allocation error in SMUMPS_INTERLEAVE_RHS_AM1'
        CALL mumps_abort()
      END IF
      DO i=1, nsteps
        mytypenode(i) = mumps_typenode_rough( procnode(i), keep199 )
      ENDDO
      nb_non_empty = 0
      DO i=1,size_perm
        IF(irhs_ptr(i+1)-irhs_ptr(i).NE.0) THEN 
          nb_non_empty = nb_non_empty + 1
        END IF
      END DO
      k = 0
      iptr_perm_working(1)=1
      DO i=1,nprocs
        used = .false.
        DO j=iptr_working(i),iptr_working(i+1)-1
          used(working(j)) = .true.        
        END DO
        DO j=1,n
          IF (used(abs(step(perm_rhs(j)))).AND.
     &      ((irhs_ptr(perm_rhs(j)+1)-irhs_ptr(perm_rhs(j))).NE.0))
     &    THEN
            k = k + 1
          END IF
        END DO
        iptr_perm_working(i+1) = k+1
      END DO
      size_perm_working = k
      ALLOCATE(perm_working(size_perm_working),
     &         stat=ierr)
      IF(ierr.GT.0) THEN
        WRITE(*,*)'Allocation error in SMUMPS_INTERLEAVE_RHS_AM1'
        CALL mumps_abort()
      END IF
      k = 0
      DO i=1,nprocs
        used = .false.
        DO j=iptr_working(i),iptr_working(i+1)-1
          used(working(j)) = .true.        
        END DO
        DO j=1,n
          IF (used(abs(step(perm_rhs(j)))).AND.
     &      ((irhs_ptr(perm_rhs(j)+1)-irhs_ptr(perm_rhs(j))).NE.0)) 
     &    THEN
            k = k + 1
            perm_working(k) = perm_rhs(j)
          END IF
        END DO
      END DO      
      IF(behaviour_l0) THEN
        n_pass = 2
        allow_above_l0 = .false.
        to_be_found = 0
        DO i=1,size_perm
          IF((mytypenode(abs(step(i))).LE.1).AND. 
     &    (irhs_ptr(i+1)-irhs_ptr(i).NE.0))       
     &    THEN
            to_be_found = to_be_found + 1
          END IF
        END DO
      ELSE
        n_pass = 1
        allow_above_l0 = .true.
        to_be_found = nb_non_empty
      END IF
      ptr_procs(1:nprocs) = iptr_perm_working(1:nprocs)
      load_procs = 0
      used = .false.
      current_proc = 1
      n_select_loc = n_select
      IF (n_select_loc.LE.0) THEN
       n_select_loc = 1
      ENDIF
      posintmprhs = 0
      DO pass=1,n_pass
        selected = 0
        DO WHILE(selected.LT.to_be_found)
          local_selected = 0
          DO WHILE(local_selected.LT.n_select_loc)
            IF(ptr_procs(current_proc).EQ.
     &        iptr_perm_working(current_proc+1))
     &      THEN 
              EXIT
            ELSE 
              entry = perm_working(ptr_procs(current_proc))
              node  = abs(step(entry))
              IF(.NOT.used(entry)) THEN
                IF(allow_above_l0.OR.(mytypenode(node).LE.1)) THEN
                  used(entry) = .true.
                  selected = selected + 1
                  local_selected = local_selected + 1
                  posintmprhs = posintmprhs + 1
                  tmp_rhs(posintmprhs) = entry
                  IF(selected.EQ.to_be_found) EXIT
                END IF
              END IF
              ptr_procs(current_proc) = ptr_procs(current_proc) + 1
            END IF
          END DO
          current_proc = mod(current_proc,nprocs)+1
        END DO
        to_be_found = nb_non_empty - to_be_found
        allow_above_l0 = .true.
        ptr_procs(1:nprocs) = iptr_perm_working(1:nprocs)
      END DO
      DO i=1,size_perm
        IF(irhs_ptr(perm_rhs(i)+1)-irhs_ptr(perm_rhs(i)).EQ.0) THEN
          posintmprhs = posintmprhs+1
          tmp_rhs(posintmprhs) = perm_rhs(i)
          IF(posintmprhs.EQ.size_perm) EXIT
        END IF
      END DO
      IF(reorder) THEN
        posintmprhs = 0 
        ALLOCATE(perm_po(n),stat=ierr)
        IF(ierr.GT.0) THEN
          WRITE(*,*)'Allocation error in INTERLEAVE_RHS_AM1'
          CALL mumps_abort()
        END IF
        DO j=1,n
          perm_po(sym_perm(j))=j
        END DO
        nblocks = n/nbrhs
        DO i = 1, nblocks
          used = .false.
          DO j=1, nbrhs
            used(tmp_rhs(nbrhs*(i-1)+j))=.true.
          END DO
          DO j=1,n
            IF(used(perm_po(j))) THEN
              posintmprhs = posintmprhs + 1
              perm_rhs(posintmprhs) = perm_po(j)
            END IF
          END DO
        END DO
        IF(mod(n,nbrhs).NE.0) THEN
          used = .false.
          DO j=1, mod(n,nbrhs)
            used(tmp_rhs(nbrhs*nblocks+j))=.true.
          END DO
          DO j=1,n
            IF(used(perm_po(j))) THEN
              posintmprhs = posintmprhs + 1
              perm_rhs(posintmprhs) = perm_po(j)
            END IF
          END DO
        END IF
        DEALLOCATE(perm_po)
      ELSE
        perm_rhs = tmp_rhs
      END IF
      DEALLOCATE(tmp_rhs,
     &           ptr_procs,
     &           load_procs,
     &           used,
     &           iptr_perm_working,
     &           perm_working,
     &           mytypenode)
      RETURN

smumps_permute_rhs_am1()

subroutine smumps_permute_rhs_am1	(	integer, intent(in)	perm_strat,
		integer, dimension(sizeperm), intent(in)	sym_perm,
		integer, dimension(nhrs), intent(in)	irhs_ptr,
		integer, intent(in)	nhrs,
		integer, dimension(sizeperm), intent(out)	perm_rhs,
		integer, intent(in)	sizeperm,
		integer, intent(out)	ierr )

Definition at line 556 of file smumps_sol_es.F.

      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

smumps_permute_rhs_gs()

subroutine smumps_permute_rhs_gs ( integer, intent(in) lp, logical, intent(in) lpok, logical, intent(in) prokg, integer, intent(in) mpg, integer, intent(in) perm_strat, integer, dimension(n), intent(in) sym_perm, integer, intent(in) n, integer, intent(in) nrhs, integer, dimension(size_irhs_ptr), intent(in) irhs_ptr, integer, intent(in) size_irhs_ptr, integer, dimension(nzrhs), intent(in) irhs_sparse, integer, intent(in) nzrhs, integer, dimension(nrhs), intent(out) perm_rhs, integer, intent(out) ierr )

private

Definition at line 465 of file smumps_sol_es.F.

      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)