OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ssol_c.F File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine smumps_sol_c (root, n, a, la, iw, liw, w, lwc, iwcb, liww, nrhs, na, lna, ne_steps, w2, mtype, icntl, from_pp, step, frere, dad, fils, ptrist, ptrfac, iw1, liw1, ptracb, liwk_ptracb, procnode_steps, slavef, info, keep, keep8, dkeep, comm_nodes, myid, myid_nodes, bufr, lbufr, lbufr_bytes, istep_to_iniv2, tab_pos_in_pere, ibeg_root_def, iend_root_def, iroot_def_rhs_col1, rhs_root, lrhs_root, size_root, master_root, rhscomp, lrhscomp, posinrhscomp_fwd, posinrhscomp_bwd, nz_rhs, nbcol_inbloc, nrhs_orig, jbeg_rhs, step2node, lstep2node, irhs_sparse, irhs_ptr, size_perm_rhs, perm_rhs, size_uns_perm_inv, uns_perm_inv, nb_fs_in_rhscomp_f, nb_fs_in_rhscomp_tot, do_nbsparse, rhs_bounds, lrhs_bounds, 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)
subroutine smumps_gather_solution (nslaves, n, myid, comm, nrhs, mtype, rhs, lrhs, ncol_rhs, jbeg_rhs, ptrist, keep, keep8, procnode_steps, iw, liw, step, buffer, size_buf, size_buf_bytes, cwork, lcwork, lscal, scaling, lscaling, rhscomp, lrhscomp, ncol_rhscomp, posinrhscomp, lpos_n, perm_rhs, size_perm_rhs)
subroutine smumps_npiv_block_add (on_master)
subroutine smumps_npiv_block_send ()
subroutine smumps_gather_solution_am1 (nslaves, n, myid, comm, nrhs, rhscomp, lrhscomp, nrhscomp_col, keep, buffer, size_buf, size_buf_bytes, lscal, scaling, lscaling, irhs_ptr_copy, lirhs_ptr_copy, irhs_sparse_copy, lirhs_sparse_copy, rhs_sparse_copy, lrhs_sparse_copy, uns_perm_inv, luns_perm_inv, posinrhscomp, lpos_row, nb_fs_in_rhscomp)
subroutine smumps_am1_block_add (scale_only)
subroutine smumps_am1_block_send ()
subroutine smumps_distsol_indices (mtype, isol_loc, ptrist, keep, keep8, iw, liw_passed, myid_nodes, n, step, procnode, nslaves, scaling_data, lscal, irhs_loc_meaningful, irhs_loc, nloc_rhs)
subroutine smumps_distributed_solution (slavef, n, myid_nodes, mtype, rhscomp, lrhscomp, nbrhs_eff, posinrhscomp, isol_loc, sol_loc, nrhs, beg_rhs, lsol_loc, ptrist, procnode_steps, keep, keep8, iw, liw, step, scaling_data, lscal, nb_rhsskipped, perm_rhs, size_perm_rhs)
subroutine smumps_scatter_rhs (nslaves, n, myid, comm, mtype, rhs, lrhs, ncol_rhs, nrhs, rhscomp, lrhscomp, ncol_rhscomp, posinrhscomp_fwd, nb_fs_in_rhscomp_f, ptrist, keep, keep8, procnode_steps, iw, liw, step, icntl, info)
subroutine smumps_get_buf_indx_rhs ()
subroutine smumps_build_posinrhscomp (nslaves, n, myid_nodes, ptrist, keep, keep8, procnode_steps, iw, liw, step, posinrhscomp_row, posinrhscomp_col, posinrhscomp_col_alloc, mtype, nbent_rhscomp, nb_fs_in_rhscomp)
subroutine smumps_build_posinrhscomp_am1 (nslaves, n, myid_nodes, ptrist, dad, keep, keep8, procnode_steps, iw, liw, step, posinrhscomp_row, posinrhscomp_col, posinrhscomp_col_alloc, mtype, irhs_ptr, nbcol_inbloc, irhs_sparse, nz_rhs, perm_rhs, size_perm_rhs, jbeg_rhs, nbent_rhscomp, nb_fs_in_rhscomp_fwd, nb_fs_in_rhscomp_tot, uns_perm_inv, size_uns_perm_inv)

Function/Subroutine Documentation

◆ smumps_am1_block_add()

subroutine smumps_gather_solution_am1::smumps_am1_block_add ( logical, intent(in) scale_only)
private

Definition at line 1602 of file ssol_c.F.

1603 LOGICAL, intent(in) :: SCALE_ONLY
1604 INTEGER III
1605 IF (scale_only) THEN
1606 iii = i
1607 IF (keep(23).NE.0) iii = uns_perm_inv(i)
1608 IF (lscal) THEN
1609 rhs_sparse_copy(iz)=rhs_sparse_copy(iz)*scaling(iii)
1610 ENDIF
1611 RETURN
1612 ENDIF
1613 CALL mpi_pack(j, 1, mpi_integer, buffer,
1614 & size_buf_bytes, pos_buf, comm, ierr )
1615 CALL mpi_pack(i, 1, mpi_integer, buffer,
1616 & size_buf_bytes, pos_buf, comm, ierr )
1617 CALL mpi_pack(rhs_sparse_copy(iz), 1, mpi_real,
1618 & buffer, size_buf_bytes, pos_buf, comm,
1619 & ierr)
1620 n2send=n2send+1
1621 IF ( pos_buf + record_size_p_1 > size_buf_bytes ) THEN
1622 CALL smumps_am1_block_send()
1623 END IF
1624 RETURN
mpi_pack
subroutine mpi_pack(inbuf, incnt, datatype, outbuf, outcnt, position, comm, ierr)
Definition mpi.f:428
smumps_am1_block_send
subroutine smumps_am1_block_send()
Definition ssol_c.F:1627

◆ smumps_am1_block_send()

subroutine smumps_gather_solution_am1::smumps_am1_block_send
private

Definition at line 1626 of file ssol_c.F.

1627 IF (n2send .NE. 0) THEN
1628 CALL mpi_pack(fin, 1, mpi_integer, buffer,
1629 & size_buf_bytes, pos_buf, comm, ierr )
1630 CALL mpi_send(buffer, pos_buf, mpi_packed, master,
1631 & gathersol, comm, ierr)
1632 ENDIF
1633 pos_buf=0
1634 n2send=0
1635 RETURN
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480

◆ smumps_build_posinrhscomp()

subroutine smumps_build_posinrhscomp ( integer, intent(in) nslaves,
integer, intent(in) n,
integer, intent(in) myid_nodes,
integer, dimension(keep(28)), intent(in) ptrist,
integer, dimension(500), intent(in) keep,
integer(8), dimension(150), intent(in) keep8,
integer, dimension(keep(28)), intent(in) procnode_steps,
integer, dimension(liw), intent(in) iw,
integer, intent(in) liw,
integer, dimension(n), intent(in) step,
integer, dimension(n), intent(out) posinrhscomp_row,
integer, dimension(n), intent(out) posinrhscomp_col,
logical, intent(in) posinrhscomp_col_alloc,
integer, intent(in) mtype,
integer, intent(out) nbent_rhscomp,
integer, intent(out) nb_fs_in_rhscomp )

Definition at line 2059 of file ssol_c.F.

2067 IMPLICIT NONE
2068 include 'mpif.h'
2069 include 'mumps_tags.h'
2070 INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW
2071 INTEGER, intent(in) :: KEEP(500)
2072 INTEGER(8), intent(in) :: KEEP8(150)
2073 INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
2074 INTEGER, intent(in) :: IW(LIW), STEP(N)
2075 INTEGER, intent(in) :: MTYPE
2076 LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC
2077 INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N)
2078 INTEGER, intent(out):: NBENT_RHSCOMP, NB_FS_IN_RHSCOMP
2079 INTEGER ISTEP
2080 INTEGER NPIV
2081 INTEGER IPOS, LIELL
2082 INTEGER JJ, J1, JCOL
2083 INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL
2084 include 'mumps_headers.h'
2085 INTEGER MUMPS_PROCNODE
2086 EXTERNAL MUMPS_PROCNODE
2087 POSINRHSCOMP_ROW = 0
2088 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0
2089 IPOSINRHSCOMP = 1
2090 DO ISTEP = 1, KEEP(28)
2091 IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),
2092 & KEEP(199))) THEN
2093 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL,
2094 & IPOS, IW, LIW, PTRIST, STEP, N )
2095.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2096 J1=IPOS+1
2097 ELSE
2098 J1=IPOS+1+LIELL
2099 END IF
2100.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2101 JCOL = IPOS+1+LIELL
2102 ELSE
2103 JCOL = IPOS+1
2104 ENDIF
2105 DO JJ = J1, J1+NPIV-1
2106 POSINRHSCOMP_ROW(IW(JJ)) = IPOSINRHSCOMP+JJ-J1
2107 ENDDO
2108 IF (POSINRHSCOMP_COL_ALLOC) THEN
2109 DO JJ = JCOL, JCOL+NPIV-1
2110 POSINRHSCOMP_COL(IW(JJ)) = IPOSINRHSCOMP+JJ-JCOL
2111 ENDDO
2112 ENDIF
2113 IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV
2114 ENDIF
2115 ENDDO
2116 NB_FS_IN_RHSCOMP = IPOSINRHSCOMP -1
2117 IF (POSINRHSCOMP_COL_ALLOC) IPOSINRHSCOMP_COL=IPOSINRHSCOMP
2118.GT. IF (IPOSINRHSCOMPN) GOTO 500
2119 DO ISTEP = 1, KEEP(28)
2120 IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),
2121 & KEEP(199))) THEN
2122 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
2123 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
2124.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2125 J1=IPOS+1
2126 ELSE
2127 J1=IPOS+1+LIELL
2128 END IF
2129.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2130 JCOL = IPOS+1+LIELL
2131 ELSE
2132 JCOL = IPOS+1
2133 ENDIF
2134 IF (POSINRHSCOMP_COL_ALLOC) THEN
2135 DO JJ = NPIV, LIELL-1-KEEP(253)
2136.EQ. IF (POSINRHSCOMP_ROW(IW(J1+JJ))0) THEN
2137 POSINRHSCOMP_ROW(IW(J1+JJ)) = - IPOSINRHSCOMP
2138 IPOSINRHSCOMP = IPOSINRHSCOMP + 1
2139 ENDIF
2140.EQ. IF (POSINRHSCOMP_COL(IW(JCOL+JJ))0) THEN
2141 POSINRHSCOMP_COL(IW(JCOL+JJ)) = - IPOSINRHSCOMP_COL
2142 IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1
2143 ENDIF
2144 ENDDO
2145 ELSE
2146 DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253)
2147.EQ. IF (POSINRHSCOMP_ROW(IW(JJ))0) THEN
2148 POSINRHSCOMP_ROW(IW(JJ)) = - IPOSINRHSCOMP
2149 IPOSINRHSCOMP = IPOSINRHSCOMP + 1
2150 ENDIF
2151 ENDDO
2152 ENDIF
2153 ENDIF
2154 ENDDO
2155 500 NBENT_RHSCOMP = IPOSINRHSCOMP - 1
2156 IF (POSINRHSCOMP_COL_ALLOC)
2157 & NBENT_RHSCOMP = max(NBENT_RHSCOMP, IPOSINRHSCOMP_COL-1)
2158 RETURN

◆ smumps_build_posinrhscomp_am1()

subroutine smumps_build_posinrhscomp_am1 ( integer, intent(in) nslaves,
integer, intent(in) n,
integer, intent(in) myid_nodes,
integer, dimension(keep(28)), intent(in) ptrist,
integer, dimension(keep(28)), intent(inout) dad,
integer, dimension(500), intent(in) keep,
integer(8), dimension(150), intent(in) keep8,
integer, dimension(keep(28)), intent(in) procnode_steps,
integer, dimension(liw), intent(in) iw,
integer, intent(in) liw,
integer, dimension(n), intent(in) step,
integer, dimension(n), intent(out) posinrhscomp_row,
integer, dimension(n), intent(out) posinrhscomp_col,
logical, intent(in) posinrhscomp_col_alloc,
integer, intent(in) mtype,
integer, dimension(nbcol_inbloc+1), intent(in) irhs_ptr,
integer, intent(in) nbcol_inbloc,
integer, dimension(nz_rhs), intent(in) irhs_sparse,
integer, intent(in) nz_rhs,
integer, dimension(size_perm_rhs), intent(in) perm_rhs,
integer, intent(in) size_perm_rhs,
integer, intent(in) jbeg_rhs,
integer, intent(out) nbent_rhscomp,
integer, intent(out) nb_fs_in_rhscomp_fwd,
integer, intent(out) nb_fs_in_rhscomp_tot,
integer, dimension(size_uns_perm_inv), intent(in) uns_perm_inv,
integer, intent(in) size_uns_perm_inv )

Definition at line 2160 of file ssol_c.F.

2173 IMPLICIT NONE
2174 include 'mpif.h'
2175 include 'mumps_tags.h'
2176 INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW,
2177 & SIZE_UNS_PERM_INV
2178 INTEGER, intent(in) :: KEEP(500)
2179 INTEGER(8), intent(in) :: KEEP8(150)
2180 INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
2181 INTEGER, intent(inout) :: DAD(KEEP(28))
2182 INTEGER, intent(in) :: IW(LIW), STEP(N)
2183 INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1)
2184 INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS)
2185 INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS)
2186 INTEGER, intent(in) :: JBEG_RHS
2187 INTEGER, intent(in) :: MTYPE
2188 LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC
2189 INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N)
2190 INTEGER, intent(out):: NBENT_RHSCOMP
2191 INTEGER, intent(out):: NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT
2192 INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV)
2193 INTEGER I, JAM1
2194 INTEGER ISTEP, OLDISTEP
2195 INTEGER NPIV
2196 INTEGER IPOS, LIELL
2197 INTEGER JJ, J1, JCOL, ABSJCOL
2198 INTEGER IPOSINRHSCOMP_ROW, IPOSINRHSCOMP_COL
2199 INTEGER NBENT_RHSCOMP_ROW, NBENT_RHSCOMP_COL
2200 LOGICAL GO_UP
2201 include 'mumps_headers.h'
2202 INTEGER MUMPS_PROCNODE
2203 EXTERNAL mumps_procnode
2204 IF(keep(237).EQ.0) THEN
2205 WRITE(*,*)'BUILD_POSINRHSCOMP_SPARSE available for A-1 only !'
2206 CALL mumps_abort()
2207 END IF
2208 posinrhscomp_row = 0
2209 IF (posinrhscomp_col_alloc) posinrhscomp_col = 0
2210 iposinrhscomp_row = 0
2211 iposinrhscomp_col = 0
2212 DO i = 1, nbcol_inbloc
2213 IF ((irhs_ptr(i+1)-irhs_ptr(i)).EQ.0) cycle
2214 IF (keep(242).NE.0) THEN
2215 jam1 = perm_rhs(jbeg_rhs+i-1)
2216 ELSE
2217 jam1 = jbeg_rhs+i-1
2218 END IF
2219 istep = abs(step(jam1))
2220 go_up = .true.
2221 DO WHILE(go_up)
2222 IF(myid_nodes.EQ.
2223 & mumps_procnode(procnode_steps(istep),keep(199))) THEN
2224 CALL mumps_sol_get_npiv_liell_ipos( istep, keep,
2225 & npiv, liell, ipos, iw, liw, ptrist, step, n )
2226 IF (mtype.eq.1 .OR. keep(50).NE.0) THEN
2227 j1=ipos+1
2228 ELSE
2229 j1=ipos+1+liell
2230 END IF
2231 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
2232 jcol = ipos+1+liell
2233 ELSE
2234 jcol = ipos+1
2235 ENDIF
2236 IF(npiv.GT.0) THEN
2237 IF(posinrhscomp_row(iw(j1)).EQ.0) THEN
2238 DO jj = j1, j1+npiv-1
2239 posinrhscomp_row(iw(jj))
2240 & = iposinrhscomp_row + jj - j1 + 1
2241 ENDDO
2242 iposinrhscomp_row = iposinrhscomp_row + npiv
2243 IF (posinrhscomp_col_alloc) THEN
2244 DO jj = jcol, jcol+npiv-1
2245 posinrhscomp_col(iw(jj))
2246 & = - n - (iposinrhscomp_col + jj - jcol + 1)
2247 ENDDO
2248 iposinrhscomp_col = iposinrhscomp_col + npiv
2249 ENDIF
2250 ELSE
2251 go_up = .false.
2252 END IF
2253 END IF
2254 END IF
2255 IF(dad(istep).NE.0) THEN
2256 istep = step(dad(istep))
2257 ELSE
2258 go_up = .false.
2259 END IF
2260 END DO
2261 END DO
2262 nb_fs_in_rhscomp_fwd = iposinrhscomp_row
2263 IF(posinrhscomp_col_alloc) THEN
2264 DO i =1, nz_rhs
2265 jam1 = irhs_sparse(i)
2266 IF (keep(23).NE.0) jam1 = uns_perm_inv(jam1)
2267 istep = abs(step(jam1))
2268 go_up = .true.
2269 DO WHILE(go_up)
2270 IF(myid_nodes.EQ.
2271 & mumps_procnode(procnode_steps(istep),keep(199))) THEN
2272 CALL mumps_sol_get_npiv_liell_ipos( istep, keep,
2273 & npiv, liell, ipos, iw, liw, ptrist, step, n )
2274 IF (mtype.eq.1 .OR. keep(50).NE.0) THEN
2275 j1=ipos+1
2276 ELSE
2277 j1=ipos+1+liell
2278 END IF
2279 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
2280 jcol = ipos+1+liell
2281 ELSE
2282 jcol = ipos+1
2283 ENDIF
2284 absjcol = abs(iw(jcol))
2285 IF(npiv.GT.0) THEN
2286 IF(posinrhscomp_col(absjcol).EQ.0) THEN
2287 DO jj = jcol, jcol+npiv-1
2288 posinrhscomp_col(abs(iw(jj))) =
2289 & iposinrhscomp_col+jj-jcol+1
2290 END DO
2291 iposinrhscomp_col = iposinrhscomp_col + npiv
2292 ELSE IF (posinrhscomp_col(absjcol).LT.-n) THEN
2293 DO jj = jcol, jcol+npiv-1
2294 posinrhscomp_col(abs(iw(jj)))=
2295 & -(n+posinrhscomp_col(abs(iw(jj))))
2296 END DO
2297 ELSE IF ((posinrhscomp_col(absjcol).LT.0).AND.
2298 & (posinrhscomp_col(absjcol).GE.-n))THEN
2299 WRITE(*,*)'Internal error 7 in BUILD...SPARSE'
2300 CALL mumps_abort()
2301 ELSE
2302 go_up = .false.
2303 END IF
2304 END IF
2305 END IF
2306 IF(dad(istep).NE.0) THEN
2307 istep = step(dad(istep))
2308 ELSE
2309 go_up = .false.
2310 END IF
2311 END DO
2312 END DO
2313 END IF
2314 nb_fs_in_rhscomp_tot = iposinrhscomp_col
2315 IF (nslaves.NE.1) THEN
2316 DO i = 1, nbcol_inbloc
2317 IF ((irhs_ptr(i+1)-irhs_ptr(i)).EQ.0) cycle
2318 IF (keep(242).NE.0) THEN
2319 jam1 = perm_rhs(jbeg_rhs+i-1)
2320 ELSE
2321 jam1 = jbeg_rhs+i-1
2322 END IF
2323 istep = abs(step(jam1))
2324 go_up = .true.
2325 DO WHILE(go_up)
2326 IF(myid_nodes.EQ.
2327 & mumps_procnode(procnode_steps(istep),keep(199))) THEN
2328 CALL mumps_sol_get_npiv_liell_ipos( istep, keep,
2329 & npiv, liell, ipos, iw, liw, ptrist, step, n )
2330 IF (mtype.eq.1 .OR. keep(50).NE.0) THEN
2331 j1=ipos+1
2332 ELSE
2333 j1=ipos+1+liell
2334 END IF
2335 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
2336 jcol = ipos+1+liell
2337 ELSE
2338 jcol = ipos+1
2339 ENDIF
2340 DO jj = npiv, liell-1-keep(253)
2341 IF(posinrhscomp_row(iw(j1+jj)).EQ.0) THEN
2342 iposinrhscomp_row = iposinrhscomp_row + 1
2343 posinrhscomp_row(iw(jj+j1))
2344 & = -iposinrhscomp_row
2345 END IF
2346 END DO
2347 END IF
2348 IF(dad(istep).GT.0) THEN
2349 oldistep=istep
2350 istep = step(dad(istep))
2351 dad(oldistep)=-dad(oldistep)
2352 ELSE
2353 go_up = .false.
2354 END IF
2355 END DO
2356 END DO
2357 dad=abs(dad)
2358 IF(posinrhscomp_col_alloc) THEN
2359 DO i =1, nz_rhs
2360 jam1 = irhs_sparse(i)
2361 IF (keep(23).NE.0) jam1 = uns_perm_inv(jam1)
2362 istep = abs(step(jam1))
2363 go_up = .true.
2364 DO WHILE(go_up)
2365 IF(myid_nodes.EQ.
2366 & mumps_procnode(procnode_steps(istep),keep(199))) THEN
2367 CALL mumps_sol_get_npiv_liell_ipos( istep, keep,
2368 & npiv, liell, ipos, iw, liw, ptrist, step, n )
2369 IF (mtype.eq.1 .OR. keep(50).NE.0) THEN
2370 j1=ipos+1
2371 ELSE
2372 j1=ipos+1+liell
2373 END IF
2374 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
2375 jcol = ipos+1+liell
2376 ELSE
2377 jcol = ipos+1
2378 ENDIF
2379 IF (keep(23).NE.0) jam1 = uns_perm_inv(jam1)
2380 DO jj = npiv, liell-1-keep(253)
2381 IF(posinrhscomp_col(iw(jcol+jj)).EQ.0) THEN
2382 iposinrhscomp_col = iposinrhscomp_col + 1
2383 posinrhscomp_col(iw(jcol+jj))
2384 & = -iposinrhscomp_col
2385 ELSE IF (posinrhscomp_col(iw(jcol+jj)).LT.-n) THEN
2386 iposinrhscomp_col = iposinrhscomp_col + 1
2387 posinrhscomp_col(iw(jcol+jj))
2388 & = posinrhscomp_col(iw(jcol+jj)) + n
2389 END IF
2390 END DO
2391 END IF
2392 IF(dad(istep).GT.0) THEN
2393 oldistep=istep
2394 istep = step(dad(istep))
2395 dad(oldistep)=-dad(oldistep)
2396 ELSE
2397 go_up = .false.
2398 END IF
2399 END DO
2400 END DO
2401 dad=abs(dad)
2402 END IF
2403 ENDIF
2404 nbent_rhscomp_row = iposinrhscomp_row
2405 nbent_rhscomp_col = iposinrhscomp_col
2406 nbent_rhscomp = max(nbent_rhscomp_row,nbent_rhscomp_col)
2407 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
max
#define max(a, b)
Definition macros.h:21
mumps_sol_get_npiv_liell_ipos
subroutine mumps_sol_get_npiv_liell_ipos(istep, keep, npiv, liell, ipos, iw, liw, ptrist, step, n)
Definition sol_common.F:16
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151

◆ smumps_distributed_solution()

subroutine smumps_distributed_solution ( integer slavef,
integer n,
integer myid_nodes,
integer mtype,
real, dimension( lrhscomp, nbrhs_eff ) rhscomp,
integer lrhscomp,
integer nbrhs_eff,
integer, dimension(n) posinrhscomp,
integer, dimension(lsol_loc) isol_loc,
real, dimension( lsol_loc, nrhs ) sol_loc,
integer, intent(in) nrhs,
integer beg_rhs,
integer lsol_loc,
integer, dimension(keep(28)) ptrist,
integer, dimension(keep(28)) procnode_steps,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer, dimension(liw) iw,
integer liw,
integer, dimension(n) step,
type (scaling_data_t) scaling_data,
logical lscal,
integer nb_rhsskipped,
integer, dimension( size_perm_rhs ), intent(in) perm_rhs,
integer, intent(in) size_perm_rhs )

Definition at line 1709 of file ssol_c.F.

1719 IMPLICIT NONE
1720 include 'mpif.h'
1721 include 'mumps_tags.h'
1722 type scaling_data_t
1723 sequence
1724 REAL, dimension(:), pointer :: SCALING
1725 REAL, dimension(:), pointer :: SCALING_LOC
1726 end type scaling_data_t
1727 TYPE (scaling_data_t) :: scaling_data
1728 LOGICAL LSCAL
1729 INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSCOMP
1730 INTEGER POSINRHSCOMP(N), NB_RHSSKIPPED
1731 INTEGER LSOL_LOC, BEG_RHS
1732 INTEGER ISOL_LOC(LSOL_LOC)
1733 INTEGER, INTENT(in) :: NRHS
1734 REAL SOL_LOC( LSOL_LOC, NRHS )
1735 REAL RHSCOMP( LRHSCOMP, NBRHS_EFF )
1736 INTEGER KEEP(500)
1737 INTEGER(8) KEEP8(150)
1738 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
1739 INTEGER IW(LIW), STEP(N)
1740 INTEGER, INTENT(in) :: SIZE_PERM_RHS
1741 INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS )
1742 INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSCOMP, JEMPTY
1743 INTEGER :: JCOL, JCOL_PERM
1744 INTEGER :: IPOS, LIELL, NPIV, JEND
1745 LOGICAL :: ROOT
1746!$ LOGICAL :: OMP_FLAG
1747 REAL, PARAMETER :: ZERO = 0.0e0
1748 include 'mumps_headers.h'
1749 INTEGER MUMPS_PROCNODE
1750 EXTERNAL mumps_procnode
1751 k=0
1752 jempty = beg_rhs+nb_rhsskipped-1
1753 jend = beg_rhs+nb_rhsskipped+nbrhs_eff-1
1754 DO istep = 1, keep(28)
1755 IF (myid_nodes == mumps_procnode(procnode_steps(istep),
1756 & keep(199))) THEN
1757 root=.false.
1758 IF (keep(38).ne.0) root = step(keep(38))==istep
1759 IF (keep(20).ne.0) root = step(keep(20))==istep
1760 IF ( root ) THEN
1761 ipos = ptrist(istep) + keep(ixsz)
1762 liell = iw(ipos+3)
1763 npiv = liell
1764 ipos= ptrist(istep)+5+keep(ixsz)
1765 ELSE
1766 ipos = ptrist(istep) + 2 +keep(ixsz)
1767 liell = iw(ipos-2)+iw(ipos+1)
1768 ipos= ipos+1
1769 npiv = iw(ipos)
1770 ipos= ipos+1
1771 ipos= ipos+1+iw( ptrist(istep) + 5 +keep(ixsz))
1772 END IF
1773 IF (mtype.eq.1 .AND. keep(50).EQ.0) THEN
1774 j1=ipos+1+liell
1775 ELSE
1776 j1=ipos+1
1777 END IF
1778 IF (nb_rhsskipped.GT.0) THEN
1779 DO jcol = beg_rhs, jempty
1780 IF (keep(242) .NE. 0) THEN
1781 jcol_perm = perm_rhs(jcol)
1782 ELSE
1783 jcol_perm = jcol
1784 ENDIF
1785 kloc=k
1786 DO jj=j1,j1+npiv-1
1787 kloc=kloc+1
1788 sol_loc(kloc, jcol_perm) = zero
1789 ENDDO
1790 ENDDO
1791 ENDIF
1792!$ omp_flag = ( jend-jempty.GE.keep(362) .AND.
1793!$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) )
1794!$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSCOMP)
1795!$OMP& IF(OMP_FLAG)
1796 DO jcol = jempty+1, jend
1797 IF (keep(242) .NE. 0) THEN
1798 jcol_perm = perm_rhs(jcol)
1799 ELSE
1800 jcol_perm = jcol
1801 ENDIF
1802 DO jj=j1,j1+npiv-1
1803 kloc=k + jj-j1 + 1
1804 iposinrhscomp = posinrhscomp(iw(jj))
1805 IF (lscal) THEN
1806 sol_loc(kloc,jcol_perm) =
1807 & scaling_data%SCALING_LOC(kloc)*
1808 & rhscomp(iposinrhscomp,jcol-jempty)
1809 ELSE
1810 sol_loc(kloc,jcol_perm) =
1811 & rhscomp(iposinrhscomp,jcol-jempty)
1812 ENDIF
1813 ENDDO
1814 ENDDO
1815!$OMP END PARALLEL DO
1816 k=k+npiv
1817 ENDIF
1818 ENDDO
1819 RETURN

◆ smumps_distsol_indices()

subroutine smumps_distsol_indices ( integer mtype,
integer, dimension(keep(89)) isol_loc,
integer, dimension(keep(28)) ptrist,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer, dimension(liw_passed) iw,
integer liw_passed,
integer myid_nodes,
integer n,
integer, dimension(n) step,
integer, dimension(keep(28)) procnode,
integer nslaves,
type (scaling_data_t) scaling_data,
logical lscal,
logical irhs_loc_meaningful,
integer, dimension(nloc_rhs) irhs_loc,
integer nloc_rhs )

Definition at line 1638 of file ssol_c.F.

1644 IMPLICIT NONE
1645 INTEGER MTYPE, MYID_NODES, N, NSLAVES
1646 INTEGER KEEP(500)
1647 INTEGER(8) KEEP8(150)
1648 INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28))
1649 INTEGER ISOL_LOC(KEEP(89))
1650 INTEGER LIW_PASSED
1651 INTEGER IW(LIW_PASSED)
1652 INTEGER STEP(N)
1653 LOGICAL LSCAL
1654 LOGICAL :: IRHS_loc_MEANINGFUL
1655 INTEGER :: Nloc_RHS
1656 INTEGER :: IRHS_loc(Nloc_RHS)
1657 type scaling_data_t
1658 sequence
1659 REAL, dimension(:), pointer :: SCALING
1660 REAL, dimension(:), pointer :: SCALING_LOC
1661 end type scaling_data_t
1662 type (scaling_data_t) :: scaling_data
1663 INTEGER MUMPS_PROCNODE
1664 EXTERNAL mumps_procnode
1665 INTEGER ISTEP, K
1666 INTEGER J1, IPOS, LIELL, NPIV, JJ
1667 LOGICAL :: CHECK_IRHS_loc
1668 INTEGER(8) :: DIFF_ADDR
1669 include 'mumps_headers.h'
1670 check_irhs_loc=.false.
1671 IF ( irhs_loc_meaningful ) THEN
1672 IF (nloc_rhs .GT. 0) THEN
1673 CALL mumps_size_c( irhs_loc(1), isol_loc(1),
1674 & diff_addr )
1675 IF (diff_addr .EQ. 0_8) THEN
1676 check_irhs_loc=.true.
1677 ENDIF
1678 ENDIF
1679 ENDIF
1680 k=0
1681 DO istep=1, keep(28)
1682 IF ( myid_nodes == mumps_procnode( procnode(istep),
1683 & keep(199))) THEN
1684 CALL mumps_sol_get_npiv_liell_ipos( istep, keep,
1685 & npiv, liell, ipos, iw, liw_passed, ptrist, step, n)
1686 IF (mtype.eq.1 .AND. keep(50).EQ.0) THEN
1687 j1=ipos+1+liell
1688 ELSE
1689 j1=ipos+1
1690 END IF
1691 DO jj=j1,j1+npiv-1
1692 k=k+1
1693 IF (check_irhs_loc) THEN
1694 IF (k.LE.nloc_rhs) THEN
1695 IF ( iw(jj) .NE.irhs_loc(k) ) THEN
1696 ENDIF
1697 ENDIF
1698 ENDIF
1699 isol_loc(k)=iw(jj)
1700 IF (lscal) THEN
1701 scaling_data%SCALING_LOC(k)=
1702 & scaling_data%SCALING(iw(jj))
1703 ENDIF
1704 ENDDO
1705 ENDIF
1706 ENDDO
1707 RETURN

◆ smumps_gather_solution()

subroutine smumps_gather_solution ( integer nslaves,
integer n,
integer myid,
integer comm,
integer nrhs,
integer mtype,
real, dimension (lrhs, ncol_rhs) rhs,
integer lrhs,
integer ncol_rhs,
integer, intent(in) jbeg_rhs,
integer, dimension(keep(28)) ptrist,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer, dimension(keep(28)) procnode_steps,
integer, dimension(liw) iw,
integer liw,
integer, dimension(n) step,
integer, dimension(size_buf) buffer,
integer size_buf,
integer size_buf_bytes,
real, dimension(lcwork) cwork,
integer lcwork,
logical, intent(in) lscal,
real, dimension(lscaling), intent(in) scaling,
integer, intent(in) lscaling,
real, dimension(lrhscomp, ncol_rhscomp), intent(in) rhscomp,
integer lrhscomp,
integer ncol_rhscomp,
integer, dimension(lpos_n) posinrhscomp,
integer lpos_n,
integer, dimension(size_perm_rhs), intent(in) perm_rhs,
integer, intent(in) size_perm_rhs )

Definition at line 1075 of file ssol_c.F.

1083!$ USE OMP_LIB
1084 IMPLICIT NONE
1085 include 'mpif.h'
1086 include 'mumps_tags.h'
1087 INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS
1088 INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSCOMP
1089 REAL RHS (LRHS, NCOL_RHS)
1090 INTEGER, INTENT(in) :: JBEG_RHS
1091 INTEGER KEEP(500)
1092 INTEGER(8) KEEP8(150)
1093 REAL :: CWORK(LCWORK)
1094 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
1095 INTEGER IW(LIW), STEP(N)
1096 INTEGER SIZE_BUF, SIZE_BUF_BYTES
1097 INTEGER BUFFER(SIZE_BUF)
1098 INTEGER LRHSCOMP, POSINRHSCOMP(LPOS_N)
1099 REAL, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP)
1100 LOGICAL, intent(in) :: LSCAL
1101 INTEGER, intent(in) :: LSCALING
1102 REAL, intent(in) :: SCALING(LSCALING)
1103 INTEGER, INTENT(in) :: SIZE_PERM_RHS
1104 INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS)
1105 INTEGER I, II, J, J1, ISTEP, MASTER,
1106 & MYID_NODES, TYPE_PARAL, N2RECV
1107 INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf
1108 INTEGER :: STATUS(MPI_STATUS_SIZE)
1109 INTEGER :: IERR, allocok
1110 parameter(master=0)
1111 LOGICAL I_AM_SLAVE
1112 INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2
1113 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP
1114 INTEGER :: JCOL_RHS
1115 INTEGER :: K242
1116 LOGICAL :: OMP_FLAG
1117!$ INTEGER :: CHUNK, NOMP
1118 INTEGER, PARAMETER :: FIN = -1
1119 REAL ZERO
1120 parameter( zero = 0.0e0 )
1121 INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist
1122 include 'mumps_headers.h'
1123 INTEGER, EXTERNAL :: MUMPS_PROCNODE
1124 type_paral = keep(46)
1125 i_am_slave = myid .ne. master .OR. type_paral .eq. 1
1126 IF ( type_paral == 1 ) THEN
1127 myid_nodes = myid
1128 ELSE
1129 myid_nodes = myid-1
1130 ENDIF
1131 IF (nslaves.EQ.1 .AND. type_paral.EQ.1) THEN
1132 IF (lscal) THEN
1133 omp_flag = .false.
1134 IF (keep(350).EQ.2) THEN
1135 k242 = keep(242)
1136!$ NOMP = OMP_GET_MAX_THREADS()
1137!$ CHUNK = max(N/2,1)
1138!$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN
1139!$ OMP_FLAG = .TRUE.
1140!$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8))
1141!$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362))
1142!$ CHUNK = max(KEEP(363)/2,CHUNK)
1143!$ ENDIF
1144 ENDIF
1145 IF (omp_flag) THEN
1146!$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242)
1147!$OMP& PRIVATE(J,IPOSINRHSCOMP,I,JCOL_RHS)
1148 DO j=1, nrhs
1149 IF (k242.EQ.0) THEN
1150 jcol_rhs = j+jbeg_rhs-1
1151 ELSE
1152 jcol_rhs = perm_rhs(j+jbeg_rhs-1)
1153 ENDIF
1154!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
1155 DO i=1, n
1156 iposinrhscomp = posinrhscomp(i)
1157 IF (iposinrhscomp.GT.0) THEN
1158 rhs(i,jcol_rhs) =
1159 & rhscomp(iposinrhscomp,j)*scaling(i)
1160 ELSE
1161 rhs(i,jcol_rhs) = zero
1162 ENDIF
1163 ENDDO
1164!$OMP END DO NOWAIT
1165 ENDDO
1166!$OMP END PARALLEL
1167 ELSE
1168 DO j=1, nrhs
1169 IF (keep(242).EQ.0) THEN
1170 jcol_rhs = j+jbeg_rhs-1
1171 ELSE
1172 jcol_rhs = perm_rhs(j+jbeg_rhs-1)
1173 ENDIF
1174 DO i=1, n
1175 iposinrhscomp = posinrhscomp(i)
1176 IF (iposinrhscomp.GT.0) THEN
1177 rhs(i,jcol_rhs) =
1178 & rhscomp(iposinrhscomp,j)*scaling(i)
1179 ELSE
1180 rhs(i,jcol_rhs) = zero
1181 ENDIF
1182 ENDDO
1183 ENDDO
1184 ENDIF
1185 ELSE
1186 omp_flag = .false.
1187 IF (keep(350).EQ.2) THEN
1188 k242 = keep(242)
1189!$ NOMP = OMP_GET_MAX_THREADS()
1190!$ OMP_FLAG = .FALSE.
1191!$ CHUNK = max(N/2,1)
1192!$ IF (NRHS * N .GE. KEEP(363)) THEN
1193!$ OMP_FLAG = .TRUE.
1194!$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8))
1195!$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362))
1196!$ chunk = max(keep(363)/2,chunk)
1197!$ ENDIF
1198 ENDIF
1199 IF (omp_flag) THEN
1200!$omp parallel firstprivate(jbeg_rhs,n,k242)
1201!$omp& private(iposinrhscomp,i,jcol_rhs) IF (omp_flag)
1202 DO j=1, nrhs
1203 IF (k242.EQ.0) THEN
1204 jcol_rhs = j+jbeg_rhs-1
1205 ELSE
1206 jcol_rhs = perm_rhs(j+jbeg_rhs-1)
1207 ENDIF
1208!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
1209 DO i=1, n
1210 iposinrhscomp = posinrhscomp(i)
1211 IF (iposinrhscomp.GT.0) THEN
1212 rhs(i,jcol_rhs) = rhscomp(iposinrhscomp,j)
1213 ELSE
1214 rhs(i,jcol_rhs) = zero
1215 ENDIF
1216 ENDDO
1217!$OMP END DO NOWAIT
1218 ENDDO
1219!$OMP END PARALLEL
1220 ELSE
1221 DO j=1, nrhs
1222 IF (keep(242).EQ.0) THEN
1223 jcol_rhs = j+jbeg_rhs-1
1224 ELSE
1225 jcol_rhs = perm_rhs(j+jbeg_rhs-1)
1226 ENDIF
1227 DO i=1, n
1228 iposinrhscomp = posinrhscomp(i)
1229 IF (iposinrhscomp.GT.0) THEN
1230 rhs(i,jcol_rhs) = rhscomp(iposinrhscomp,j)
1231 ELSE
1232 rhs(i,jcol_rhs) = zero
1233 ENDIF
1234 ENDDO
1235 ENDDO
1236 ENDIF
1237 ENDIF
1238 RETURN
1239 ENDIF
1240 maxnpiv_estim = max(keep(246), keep(247))
1241 maxsurf = maxnpiv_estim*nrhs
1242 IF (lcwork .LT. maxnpiv_estim) THEN
1243 WRITE(*,*) myid,
1244 & ": Internal error 2 in SMUMPS_GATHER_SOLUTION:",
1245 & type_paral, lcwork, keep(247), nrhs
1246 CALL mumps_abort()
1247 ENDIF
1248 IF (myid.EQ.master) THEN
1249 ALLOCATE(irowlist(keep(247)),stat=allocok)
1250 IF(allocok.GT.0) THEN
1251 WRITE(*,*)'Problem with allocation of IROWlist'
1252 CALL mumps_abort()
1253 ENDIF
1254 ENDIF
1255 IF (nslaves .EQ. 1 .AND. type_paral .EQ. 1) THEN
1256 CALL mumps_abort()
1257 ENDIF
1258 size1=0
1259 CALL mpi_pack_size(maxnpiv_estim+2,mpi_integer, comm,
1260 & size1, ierr)
1261 size2=0
1262 CALL mpi_pack_size(maxsurf,mpi_real, comm,
1263 & size2, ierr)
1264 record_size_p_1= size1+size2
1265 IF (record_size_p_1.GT.size_buf_bytes) THEN
1266 write(6,*) myid,
1267 & ' Internal error 3 in SMUMPS_GATHER_SOLUTION '
1268 write(6,*) myid, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=',
1269 & record_size_p_1, size_buf_bytes
1270 CALL mumps_abort()
1271 ENDIF
1272 n2send =0
1273 n2recv =n
1274 pos_buf =0
1275 IF (i_am_slave) THEN
1276 pos_buf = 0
1277 DO istep = 1, keep(28)
1278 IF (myid_nodes == mumps_procnode(procnode_steps(istep),
1279 & keep(199))) THEN
1280 CALL mumps_sol_get_npiv_liell_ipos( istep, keep,
1281 & npiv, liell, ipos, iw, liw, ptrist, step, n)
1282 IF (mtype.eq.1 .AND. keep(50).EQ.0) THEN
1283 j1=ipos+1+liell
1284 ELSE
1285 j1=ipos+1
1286 END IF
1287 IF (myid .EQ. master) THEN
1288 n2recv=n2recv-npiv
1289 IF (npiv.GT.0)
1290 & CALL smumps_npiv_block_add ( .true. )
1291 ELSE
1292 IF (npiv.GT.0)
1293 & CALL smumps_npiv_block_add ( .false.)
1294 ENDIF
1295 ENDIF
1296 ENDDO
1297 CALL smumps_npiv_block_send()
1298 ENDIF
1299 IF ( myid .EQ. master ) THEN
1300 DO WHILE (n2recv .NE. 0)
1301 CALL mpi_recv( buffer, size_buf_bytes, mpi_packed,
1302 & mpi_any_source,
1303 & gathersol, comm, status, ierr )
1304 pos_buf = 0
1305 CALL mpi_unpack( buffer,size_buf_bytes, pos_buf,
1306 & npiv, 1, mpi_integer, comm, ierr)
1307 DO WHILE (npiv.NE.fin)
1308 CALL mpi_unpack( buffer,size_buf_bytes, pos_buf,
1309 & irowlist, npiv, mpi_integer, comm, ierr)
1310 DO j=1, nrhs
1311 IF (keep(242).EQ.0) THEN
1312 jcol_rhs=j+jbeg_rhs-1
1313 ELSE
1314 jcol_rhs=perm_rhs(j+jbeg_rhs-1)
1315 ENDIF
1316 CALL mpi_unpack(buffer, size_buf_bytes, pos_buf,
1317 & cwork, npiv, mpi_real,
1318 & comm, ierr)
1319 IF (lscal) THEN
1320 DO i=1,npiv
1321 rhs(irowlist(i),jcol_rhs)=cwork(i)*scaling(irowlist(i))
1322 ENDDO
1323 ELSE
1324 DO i=1,npiv
1325 rhs(irowlist(i),jcol_rhs)=cwork(i)
1326 ENDDO
1327 ENDIF
1328 ENDDO
1329 n2recv=n2recv-npiv
1330 CALL mpi_unpack( buffer, size_buf_bytes, pos_buf,
1331 & npiv, 1, mpi_integer, comm, ierr)
1332 ENDDO
1333 ENDDO
1334 DEALLOCATE(irowlist)
1335 ENDIF
1336 RETURN
1337 CONTAINS
1338 SUBROUTINE smumps_npiv_block_add ( ON_MASTER )
1339 LOGICAL, intent(in) :: ON_MASTER
1340 INTEGER :: JPOS, K242
1341 LOGICAL :: LOCAL_LSCAL
1342 IF (on_master) THEN
1343 IF (keep(350).EQ.2
1344 & .AND. (nrhs.EQ.1.OR.((npiv*nrhs*2*keep(16)).GE.keep(364)))) THEN
1345 local_lscal = lscal
1346 k242 = keep(242)
1347 DO j=1, nrhs
1348 IF (k242.EQ.0) THEN
1349 jpos = j+jbeg_rhs-1
1350 ELSE
1351 jpos = perm_rhs(j+jbeg_rhs-1)
1352 ENDIF
1353 DO ii=1,npiv
1354 i=iw(j1+ii-1)
1355 iposinrhscomp= posinrhscomp(i)
1356 IF (local_lscal) THEN
1357 rhs(i,jpos) = rhscomp(iposinrhscomp,j)*scaling(i)
1358 ELSE
1359 rhs(i,jpos) = rhscomp(iposinrhscomp,j)
1360 ENDIF
1361 ENDDO
1362 ENDDO
1363 ELSE
1364 IF (keep(242).EQ.0) THEN
1365 IF (lscal) THEN
1366 DO ii=1,npiv
1367 i=iw(j1+ii-1)
1368 iposinrhscomp= posinrhscomp(i)
1369 DO j=1, nrhs
1370 rhs(i,j+jbeg_rhs-1) =
1371 & rhscomp(iposinrhscomp,j)*scaling(i)
1372 ENDDO
1373 ENDDO
1374 ELSE
1375 DO ii=1,npiv
1376 i=iw(j1+ii-1)
1377 iposinrhscomp= posinrhscomp(i)
1378 DO j=1, nrhs
1379 rhs(i,j+jbeg_rhs-1) = rhscomp(iposinrhscomp,j)
1380 ENDDO
1381 ENDDO
1382 ENDIF
1383 ELSE
1384 IF (lscal) THEN
1385 DO ii=1,npiv
1386 i=iw(j1+ii-1)
1387 iposinrhscomp= posinrhscomp(i)
1388!DIR$ NOVECTOR
1389 DO j=1, nrhs
1390 rhs(i,perm_rhs(j+jbeg_rhs-1)) =
1391 & rhscomp(iposinrhscomp,j)*scaling(i)
1392 ENDDO
1393 ENDDO
1394 ELSE
1395 DO ii=1,npiv
1396 i=iw(j1+ii-1)
1397 iposinrhscomp= posinrhscomp(i)
1398!DIR$ NOVECTOR
1399 DO j=1, nrhs
1400 rhs(i,perm_rhs(j+jbeg_rhs-1)) =
1401 & rhscomp(iposinrhscomp,j)
1402 ENDDO
1403 ENDDO
1404 ENDIF
1405 ENDIF
1406 ENDIF
1407 RETURN
1408 ENDIF
1409 CALL mpi_pack(npiv, 1, mpi_integer, buffer,
1410 & size_buf_bytes, pos_buf, comm, ierr )
1411 CALL mpi_pack(iw(j1), npiv, mpi_integer, buffer,
1412 & size_buf_bytes, pos_buf, comm, ierr )
1413 iposinrhscomp= posinrhscomp(iw(j1))
1414 DO j=1,nrhs
1415 CALL mpi_pack(rhscomp(iposinrhscomp,j), npiv,
1416 & mpi_real,
1417 & buffer, size_buf_bytes, pos_buf, comm,
1418 & ierr)
1419 ENDDO
1420 n2send=n2send+npiv
1421 IF ( pos_buf + record_size_p_1 > size_buf_bytes ) THEN
1422 CALL smumps_npiv_block_send()
1423 END IF
1424 RETURN
1425 END SUBROUTINE smumps_npiv_block_add
1426 SUBROUTINE smumps_npiv_block_send()
1427 IF (n2send .NE. 0) THEN
1428 CALL mpi_pack(fin, 1, mpi_integer, buffer,
1429 & size_buf_bytes, pos_buf, comm, ierr )
1430 CALL mpi_send(buffer, pos_buf, mpi_packed, master,
1431 & gathersol, comm, ierr)
1432 ENDIF
1433 pos_buf=0
1434 n2send=0
1435 RETURN
1436 END SUBROUTINE smumps_npiv_block_send
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_pack_size
subroutine mpi_pack_size(incnt, datatype, comm, size, ierr)
Definition mpi.f:439
mpi_unpack
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
smumps_npiv_block_send
subroutine smumps_npiv_block_send()
Definition ssol_c.F:1427
smumps_npiv_block_add
subroutine smumps_npiv_block_add(on_master)
Definition ssol_c.F:1339

◆ smumps_gather_solution_am1()

subroutine smumps_gather_solution_am1 ( integer nslaves,
integer n,
integer myid,
integer comm,
integer nrhs,
real, dimension (lrhscomp, nrhscomp_col), intent(in) rhscomp,
integer lrhscomp,
integer nrhscomp_col,
integer, dimension(500) keep,
integer, dimension(size_buf) buffer,
integer size_buf,
integer size_buf_bytes,
logical, intent(in) lscal,
real, dimension(lscaling), intent(in) scaling,
integer, intent(in) lscaling,
integer, dimension(lirhs_ptr_copy) irhs_ptr_copy,
integer, intent(in) lirhs_ptr_copy,
integer, dimension(lirhs_sparse_copy) irhs_sparse_copy,
integer, intent(in) lirhs_sparse_copy,
real, dimension(lrhs_sparse_copy) rhs_sparse_copy,
integer, intent(in) lrhs_sparse_copy,
integer, dimension(luns_perm_inv) uns_perm_inv,
integer, intent(in) luns_perm_inv,
integer, dimension(lpos_row) posinrhscomp,
integer lpos_row,
integer, intent(in) nb_fs_in_rhscomp )

Definition at line 1438 of file ssol_c.F.

1448 IMPLICIT NONE
1449 include 'mpif.h'
1450 include 'mumps_tags.h'
1451 INTEGER NSLAVES, N, MYID, COMM
1452 INTEGER NRHS, LRHSCOMP, NRHSCOMP_COL
1453 REAL, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL)
1454 INTEGER KEEP(500)
1455 INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW
1456 INTEGER BUFFER(SIZE_BUF)
1457 INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY,
1458 & LRHS_SPARSE_COPY, LUNS_PERM_INV,
1459 & NB_FS_IN_RHSCOMP
1460 INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY),
1461 & IRHS_PTR_COPY(LIRHS_PTR_COPY),
1462 & UNS_PERM_INV(LUNS_PERM_INV),
1463 & POSINRHSCOMP(LPOS_ROW)
1464 REAL :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY)
1465 LOGICAL, intent(in) :: LSCAL
1466 INTEGER, intent(in) :: LSCALING
1467 REAL, intent(in) :: SCALING(LSCALING)
1468 INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC
1469 INTEGER I, II, J, MASTER,
1470 & TYPE_PARAL, N2RECV, IPOSINRHSCOMP
1471 INTEGER :: STATUS(MPI_STATUS_SIZE)
1472 INTEGER :: IERR
1473 parameter(master=0)
1474 LOGICAL I_AM_SLAVE
1475 INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2
1476 INTEGER POS_BUF, N2SEND
1477 INTEGER, PARAMETER :: FIN = -1
1478 include 'mumps_headers.h'
1479 type_paral = keep(46)
1480 i_am_slave = myid .ne. master .OR. type_paral .eq. 1
1481 nbcol_inbloc = size(irhs_ptr_copy)-1
1482 IF (nslaves.EQ.1 .AND. type_paral.EQ.1) THEN
1483 k=1
1484 DO j = 1, nbcol_inbloc
1485 colsize = irhs_ptr_copy(j+1) - irhs_ptr_copy(j)
1486 IF (colsize.EQ.0) cycle
1487 DO iz=irhs_ptr_copy(j), irhs_ptr_copy(j+1)-1
1488 i = irhs_sparse_copy(iz)
1489 IF (keep(23).NE.0) i = uns_perm_inv(i)
1490 iposinrhscomp = posinrhscomp(i)
1491 IF (iposinrhscomp.GT.0) THEN
1492 IF (lscal) THEN
1493 rhs_sparse_copy(iz)=
1494 & rhscomp(iposinrhscomp,k)*scaling(i)
1495 ELSE
1496 rhs_sparse_copy(iz)=rhscomp(iposinrhscomp,k)
1497 ENDIF
1498 ENDIF
1499 ENDDO
1500 k = k + 1
1501 ENDDO
1502 RETURN
1503 ENDIF
1504 IF (i_am_slave) THEN
1505 k=1
1506 DO j = 1, nbcol_inbloc
1507 colsize = irhs_ptr_copy(j+1) - irhs_ptr_copy(j)
1508 IF (colsize.EQ.0) cycle
1509 DO iz=irhs_ptr_copy(j), irhs_ptr_copy(j+1)-1
1510 i = irhs_sparse_copy(iz)
1511 IF (keep(23).NE.0) i = uns_perm_inv(i)
1512 iposinrhscomp = posinrhscomp(i)
1513 IF (iposinrhscomp.GT.0) THEN
1514 rhs_sparse_copy(iz)=rhscomp(iposinrhscomp,k)
1515 ENDIF
1516 ENDDO
1517 k = k + 1
1518 ENDDO
1519 ENDIF
1520 size1=0
1521 CALL mpi_pack_size(3,mpi_integer, comm,
1522 & size1, ierr)
1523 size2=0
1524 CALL mpi_pack_size(1,mpi_real, comm,
1525 & size2, ierr)
1526 record_size_p_1= size1+size2
1527 IF (record_size_p_1.GT.size_buf_bytes) THEN
1528 write(6,*) myid,
1529 & ' Internal error 3 in SMUMPS_GATHER_SOLUTION_AM1 '
1530 write(6,*) myid, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=',
1531 & record_size_p_1, size_buf_bytes
1532 CALL mumps_abort()
1533 ENDIF
1534 n2send =0
1535 n2recv =size(irhs_sparse_copy)
1536 pos_buf =0
1537 IF (i_am_slave) THEN
1538 DO j = 1, nbcol_inbloc
1539 colsize = irhs_ptr_copy(j+1) - irhs_ptr_copy(j)
1540 IF (colsize.LE.0) cycle
1541 k = 0
1542 DO iz=irhs_ptr_copy(j), irhs_ptr_copy(j+1)-1
1543 i = irhs_sparse_copy(iz)
1544 ii = i
1545 IF (keep(23).NE.0) ii = uns_perm_inv(i)
1546 iposinrhscomp = posinrhscomp(ii)
1547 IF (iposinrhscomp.GT.0) THEN
1548 IF (myid .EQ. master) THEN
1549 n2recv=n2recv-1
1550 IF (lscal)
1551 & CALL smumps_am1_block_add ( .true. )
1552 irhs_sparse_copy( irhs_ptr_copy(j) + k) =
1553 & i
1554 rhs_sparse_copy( irhs_ptr_copy(j) + k) =
1555 & rhs_sparse_copy(iz)
1556 k = k+1
1557 ELSE
1558 CALL smumps_am1_block_add ( .false. )
1559 ENDIF
1560 ENDIF
1561 ENDDO
1562 IF (myid.EQ.master)
1563 & irhs_ptr_copy(j) = irhs_ptr_copy(j) + k
1564 ENDDO
1565 CALL smumps_am1_block_send()
1566 ENDIF
1567 IF ( myid .EQ. master ) THEN
1568 DO WHILE (n2recv .NE. 0)
1569 CALL mpi_recv( buffer, size_buf_bytes, mpi_packed,
1570 & mpi_any_source,
1571 & gathersol, comm, status, ierr )
1572 pos_buf = 0
1573 CALL mpi_unpack( buffer,size_buf_bytes, pos_buf,
1574 & j, 1, mpi_integer, comm, ierr)
1575 DO WHILE (j.NE.fin)
1576 iz = irhs_ptr_copy(j)
1577 CALL mpi_unpack( buffer,size_buf_bytes, pos_buf,
1578 & i, 1, mpi_integer, comm, ierr)
1579 irhs_sparse_copy(iz) = i
1580 CALL mpi_unpack(buffer, size_buf_bytes, pos_buf,
1581 & rhs_sparse_copy(iz), 1, mpi_real,
1582 & comm, ierr)
1583 IF (lscal) THEN
1584 IF (keep(23).NE.0) i = uns_perm_inv(i)
1585 rhs_sparse_copy(iz) = rhs_sparse_copy(iz)*scaling(i)
1586 ENDIF
1587 n2recv=n2recv-1
1588 irhs_ptr_copy(j) = irhs_ptr_copy(j) + 1
1589 CALL mpi_unpack( buffer, size_buf_bytes, pos_buf,
1590 & j, 1, mpi_integer, comm, ierr)
1591 ENDDO
1592 ENDDO
1593 iprev = 1
1594 DO j=1, size(irhs_ptr_copy)-1
1595 i= irhs_ptr_copy(j)
1596 irhs_ptr_copy(j) = iprev
1597 iprev = i
1598 ENDDO
1599 ENDIF
1600 RETURN
1601 CONTAINS
1602 SUBROUTINE smumps_am1_block_add ( SCALE_ONLY )
1603 LOGICAL, intent(in) :: SCALE_ONLY
1604 INTEGER III
1605 IF (scale_only) THEN
1606 iii = i
1607 IF (keep(23).NE.0) iii = uns_perm_inv(i)
1608 IF (lscal) THEN
1609 rhs_sparse_copy(iz)=rhs_sparse_copy(iz)*scaling(iii)
1610 ENDIF
1611 RETURN
1612 ENDIF
1613 CALL mpi_pack(j, 1, mpi_integer, buffer,
1614 & size_buf_bytes, pos_buf, comm, ierr )
1615 CALL mpi_pack(i, 1, mpi_integer, buffer,
1616 & size_buf_bytes, pos_buf, comm, ierr )
1617 CALL mpi_pack(rhs_sparse_copy(iz), 1, mpi_real,
1618 & buffer, size_buf_bytes, pos_buf, comm,
1619 & ierr)
1620 n2send=n2send+1
1621 IF ( pos_buf + record_size_p_1 > size_buf_bytes ) THEN
1622 CALL smumps_am1_block_send()
1623 END IF
1624 RETURN
1625 END SUBROUTINE smumps_am1_block_add
1626 SUBROUTINE smumps_am1_block_send()
1627 IF (n2send .NE. 0) THEN
1628 CALL mpi_pack(fin, 1, mpi_integer, buffer,
1629 & size_buf_bytes, pos_buf, comm, ierr )
1630 CALL mpi_send(buffer, pos_buf, mpi_packed, master,
1631 & gathersol, comm, ierr)
1632 ENDIF
1633 pos_buf=0
1634 n2send=0
1635 RETURN
1636 END SUBROUTINE smumps_am1_block_send
smumps_am1_block_add
subroutine smumps_am1_block_add(scale_only)
Definition ssol_c.F:1603

◆ smumps_get_buf_indx_rhs()

subroutine smumps_scatter_rhs::smumps_get_buf_indx_rhs
private

Definition at line 2019 of file ssol_c.F.

2020 CALL mpi_send(buf_indx, buf_effsize, mpi_integer,
2021 & master, scatterrhsi, comm, ierr )
2022 IF (keep(350).EQ.2) THEN
2023 CALL mpi_recv(buf_rhs_2, buf_effsize*nrhs,
2024 & mpi_real,
2025 & master,
2026 & scatterrhsr, comm, status, ierr )
2027!$ OMP_FLAG = .FALSE.
2028!$ CHUNK = NRHS
2029!$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN
2030!$ OMP_FLAG = .TRUE.
2031!$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2)
2032!$ ENDIF
2033!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX)
2034!$OMP& IF (OMP_FLAG)
2035 DO k = 1, nrhs
2036 DO i = 1, buf_effsize
2037 indx = posinrhscomp_fwd(buf_indx(i))
2038 rhscomp( indx, k ) =
2039 & buf_rhs_2( i+(k-1)*buf_effsize)
2040 ENDDO
2041 ENDDO
2042!$OMP END PARALLEL DO
2043 ELSE
2044 CALL mpi_recv(buf_rhs, buf_effsize*nrhs,
2045 & mpi_real,
2046 & master,
2047 & scatterrhsr, comm, status, ierr )
2048 DO i = 1, buf_effsize
2049 indx = posinrhscomp_fwd(buf_indx(i))
2050 DO k = 1, nrhs
2051 rhscomp( indx, k ) = buf_rhs( k, i )
2052 ENDDO
2053 ENDDO
2054 END IF
2055 buf_effsize = 0
2056 RETURN

◆ smumps_npiv_block_add()

subroutine smumps_gather_solution::smumps_npiv_block_add ( logical, intent(in) on_master)
private

Definition at line 1338 of file ssol_c.F.

1339 LOGICAL, intent(in) :: ON_MASTER
1340 INTEGER :: JPOS, K242
1341 LOGICAL :: LOCAL_LSCAL
1342 IF (on_master) THEN
1343 IF (keep(350).EQ.2
1344 & .AND. (nrhs.EQ.1.OR.((npiv*nrhs*2*keep(16)).GE.keep(364)))) THEN
1345 local_lscal = lscal
1346 k242 = keep(242)
1347 DO j=1, nrhs
1348 IF (k242.EQ.0) THEN
1349 jpos = j+jbeg_rhs-1
1350 ELSE
1351 jpos = perm_rhs(j+jbeg_rhs-1)
1352 ENDIF
1353 DO ii=1,npiv
1354 i=iw(j1+ii-1)
1355 iposinrhscomp= posinrhscomp(i)
1356 IF (local_lscal) THEN
1357 rhs(i,jpos) = rhscomp(iposinrhscomp,j)*scaling(i)
1358 ELSE
1359 rhs(i,jpos) = rhscomp(iposinrhscomp,j)
1360 ENDIF
1361 ENDDO
1362 ENDDO
1363 ELSE
1364 IF (keep(242).EQ.0) THEN
1365 IF (lscal) THEN
1366 DO ii=1,npiv
1367 i=iw(j1+ii-1)
1368 iposinrhscomp= posinrhscomp(i)
1369 DO j=1, nrhs
1370 rhs(i,j+jbeg_rhs-1) =
1371 & rhscomp(iposinrhscomp,j)*scaling(i)
1372 ENDDO
1373 ENDDO
1374 ELSE
1375 DO ii=1,npiv
1376 i=iw(j1+ii-1)
1377 iposinrhscomp= posinrhscomp(i)
1378 DO j=1, nrhs
1379 rhs(i,j+jbeg_rhs-1) = rhscomp(iposinrhscomp,j)
1380 ENDDO
1381 ENDDO
1382 ENDIF
1383 ELSE
1384 IF (lscal) THEN
1385 DO ii=1,npiv
1386 i=iw(j1+ii-1)
1387 iposinrhscomp= posinrhscomp(i)
1388!DIR$ NOVECTOR
1389 DO j=1, nrhs
1390 rhs(i,perm_rhs(j+jbeg_rhs-1)) =
1391 & rhscomp(iposinrhscomp,j)*scaling(i)
1392 ENDDO
1393 ENDDO
1394 ELSE
1395 DO ii=1,npiv
1396 i=iw(j1+ii-1)
1397 iposinrhscomp= posinrhscomp(i)
1398!DIR$ NOVECTOR
1399 DO j=1, nrhs
1400 rhs(i,perm_rhs(j+jbeg_rhs-1)) =
1401 & rhscomp(iposinrhscomp,j)
1402 ENDDO
1403 ENDDO
1404 ENDIF
1405 ENDIF
1406 ENDIF
1407 RETURN
1408 ENDIF
1409 CALL mpi_pack(npiv, 1, mpi_integer, buffer,
1410 & size_buf_bytes, pos_buf, comm, ierr )
1411 CALL mpi_pack(iw(j1), npiv, mpi_integer, buffer,
1412 & size_buf_bytes, pos_buf, comm, ierr )
1413 iposinrhscomp= posinrhscomp(iw(j1))
1414 DO j=1,nrhs
1415 CALL mpi_pack(rhscomp(iposinrhscomp,j), npiv,
1416 & mpi_real,
1417 & buffer, size_buf_bytes, pos_buf, comm,
1418 & ierr)
1419 ENDDO
1420 n2send=n2send+npiv
1421 IF ( pos_buf + record_size_p_1 > size_buf_bytes ) THEN
1422 CALL smumps_npiv_block_send()
1423 END IF
1424 RETURN

◆ smumps_npiv_block_send()

subroutine smumps_gather_solution::smumps_npiv_block_send
private

Definition at line 1426 of file ssol_c.F.

1427 IF (n2send .NE. 0) THEN
1428 CALL mpi_pack(fin, 1, mpi_integer, buffer,
1429 & size_buf_bytes, pos_buf, comm, ierr )
1430 CALL mpi_send(buffer, pos_buf, mpi_packed, master,
1431 & gathersol, comm, ierr)
1432 ENDIF
1433 pos_buf=0
1434 n2send=0
1435 RETURN

◆ smumps_scatter_rhs()

subroutine smumps_scatter_rhs ( integer nslaves,
integer n,
integer myid,
integer comm,
integer mtype,
real, dimension (lrhs, ncol_rhs), intent(in) rhs,
integer lrhs,
integer ncol_rhs,
integer nrhs,
real, dimension(lrhscomp, ncol_rhscomp), intent(out) rhscomp,
integer lrhscomp,
integer ncol_rhscomp,
integer, dimension(n), intent(in) posinrhscomp_fwd,
integer, intent(in) nb_fs_in_rhscomp_f,
integer, dimension(keep(28)) ptrist,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer, dimension(keep(28)) procnode_steps,
integer, dimension(liw) iw,
integer liw,
integer, dimension(n) step,
integer, dimension(60) icntl,
integer, dimension(80) info )

Definition at line 1821 of file ssol_c.F.

1829!$ USE OMP_LIB
1830 IMPLICIT NONE
1831 include 'mpif.h'
1832 include 'mumps_tags.h'
1833 INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE
1834 INTEGER NRHS, LRHS, NCOL_RHS, LRHSCOMP, NCOL_RHSCOMP
1835 INTEGER ICNTL(60), INFO(80)
1836 REAL, intent(in) :: RHS (LRHS, NCOL_RHS)
1837 REAL, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP)
1838 INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), NB_FS_IN_RHSCOMP_F
1839 INTEGER KEEP(500)
1840 INTEGER(8) KEEP8(150)
1841 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
1842 INTEGER IW(LIW), STEP(N)
1843 INTEGER BUF_MAXSIZE, BUF_MAXREF
1844 parameter(buf_maxref=200000)
1845 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX
1846 REAL, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS
1847 REAL, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2
1848 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE
1849 INTEGER INDX
1850 INTEGER allocok
1851 REAL ZERO
1852 parameter( zero = 0.0e0 )
1853 INTEGER I, J, K, JJ, J1, ISTEP, MASTER,
1854 & MYID_NODES, TYPE_PARAL
1855 INTEGER LIELL, IPOS, NPIV
1856 INTEGER :: STATUS(MPI_STATUS_SIZE)
1857 INTEGER :: IERR
1858 parameter(master=0)
1859 LOGICAL I_AM_SLAVE
1860!$ INTEGER :: CHUNK, NOMP
1861!$ LOGICAL :: OMP_FLAG
1862 include 'mumps_headers.h'
1863 INTEGER MUMPS_PROCNODE
1864 EXTERNAL mumps_procnode
1865 type_paral = keep(46)
1866 i_am_slave = myid .ne. 0 .OR. type_paral .eq. 1
1867 IF ( type_paral == 1 ) THEN
1868 myid_nodes = myid
1869 ELSE
1870 myid_nodes = myid-1
1871 ENDIF
1872 buf_effsize = 0
1873 buf_maxsize = max(min(buf_maxref,int(2000000/nrhs)),2000)
1874 IF ( keep(350).EQ.2 ) THEN
1875!$ NOMP = OMP_GET_MAX_THREADS()
1876 ALLOCATE (buf_indx(buf_maxsize),
1877 & buf_rhs_2(buf_maxsize*nrhs),
1878 & stat=allocok)
1879 ELSE
1880 ALLOCATE (buf_indx(buf_maxsize),
1881 & buf_rhs(nrhs,buf_maxsize),
1882 & stat=allocok)
1883 END IF
1884 IF (allocok .GT. 0) THEN
1885 info(1)=-13
1886 info(2)=buf_maxsize*(nrhs+1)
1887 ENDIF
1888 CALL mumps_propinfo(icntl, info, comm, myid )
1889 IF (info(1).LT.0) RETURN
1890 IF (myid.EQ.master) THEN
1891 entries_2_process = n - keep(89)
1892 IF (type_paral.EQ.1.AND.entries_2_process.NE.0) THEN
1893 IF (nb_fs_in_rhscomp_f.LT.lrhscomp) THEN
1894 DO k=1, ncol_rhscomp
1895 DO i = nb_fs_in_rhscomp_f +1, lrhscomp
1896 rhscomp(i, k) = zero
1897 ENDDO
1898 ENDDO
1899 ENDIF
1900 ENDIF
1901 IF ( keep(350).EQ.2 ) THEN
1902 DO WHILE ( entries_2_process .NE. 0)
1903 CALL mpi_recv( buf_indx, buf_maxsize, mpi_integer,
1904 & mpi_any_source,
1905 & scatterrhsi, comm, status, ierr )
1906 CALL mpi_get_count(status,mpi_integer,buf_effsize,ierr)
1907 proc_who_asks = status(mpi_source)
1908!$ OMP_FLAG = .FALSE.
1909!$ CHUNK = NRHS
1910!$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN
1911!$ OMP_FLAG = .TRUE.
1912!$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2)
1913!$ ENDIF
1914!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX)
1915!$OMP& IF (OMP_FLAG)
1916 DO k = 1, nrhs
1917 DO i = 1, buf_effsize
1918 indx = buf_indx( i )
1919 buf_rhs_2( i+(k-1)*buf_effsize) = rhs( indx, k )
1920 ENDDO
1921 ENDDO
1922!$OMP END PARALLEL DO
1923 CALL mpi_send( buf_rhs_2,
1924 & nrhs*buf_effsize,
1925 & mpi_real, proc_who_asks,
1926 & scatterrhsr, comm, ierr)
1927 entries_2_process = entries_2_process - buf_effsize
1928 ENDDO
1929 buf_effsize= 0
1930 ELSE
1931 DO WHILE ( entries_2_process .NE. 0)
1932 CALL mpi_recv( buf_indx, buf_maxsize, mpi_integer,
1933 & mpi_any_source,
1934 & scatterrhsi, comm, status, ierr )
1935 CALL mpi_get_count( status, mpi_integer,buf_effsize,ierr)
1936 proc_who_asks = status(mpi_source)
1937 DO i = 1, buf_effsize
1938 indx = buf_indx( i )
1939 DO k = 1, nrhs
1940 buf_rhs( k, i ) = rhs( indx, k )
1941 ENDDO
1942 ENDDO
1943 CALL mpi_send( buf_rhs, nrhs*buf_effsize,
1944 & mpi_real, proc_who_asks,
1945 & scatterrhsr, comm, ierr)
1946 entries_2_process = entries_2_process - buf_effsize
1947 ENDDO
1948 buf_effsize= 0
1949 ENDIF
1950 ENDIF
1951 IF (i_am_slave) THEN
1952 IF (myid.NE.master) THEN
1953 IF (nb_fs_in_rhscomp_f.LT.lrhscomp) THEN
1954 DO k=1, ncol_rhscomp
1955 DO i = nb_fs_in_rhscomp_f +1, lrhscomp
1956 rhscomp(i, k) = zero
1957 ENDDO
1958 ENDDO
1959 ENDIF
1960 ENDIF
1961 DO istep = 1, keep(28)
1962 IF (myid_nodes == mumps_procnode(procnode_steps(istep),
1963 & keep(199))) THEN
1964 CALL mumps_sol_get_npiv_liell_ipos( istep, keep,
1965 & npiv, liell, ipos, iw, liw, ptrist, step, n )
1966 IF (mtype.eq.1 .OR. keep(50).NE.0) THEN
1967 j1=ipos+1
1968 ELSE
1969 j1=ipos+1+liell
1970 END IF
1971 IF (myid.EQ.master) THEN
1972 indx = posinrhscomp_fwd(iw(j1))
1973 IF (keep(350).EQ.2 .AND.
1974 & (nrhs.EQ.1.OR.((npiv*nrhs*2*keep(16)).GE.keep(364)))) THEN
1975!$ OMP_FLAG = .FALSE.
1976!$ CHUNK = NRHS
1977!$ IF (NPIV*NRHS .GE. KEEP(363)) THEN
1978!$ OMP_FLAG = .TRUE.
1979!$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2)
1980!$ ENDIF
1981!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ)
1982!$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG)
1983 DO k = 1, nrhs
1984 DO jj=j1,j1+npiv-1
1985 j=iw(jj)
1986 rhscomp( indx+jj-j1, k ) = rhs( j, k )
1987 ENDDO
1988 ENDDO
1989!$OMP END PARALLEL DO
1990 ELSE
1991 DO jj=j1,j1+npiv-1
1992 j=iw(jj)
1993 DO k = 1, nrhs
1994 rhscomp( indx+jj-j1, k ) = rhs( j, k )
1995 ENDDO
1996 ENDDO
1997 END IF
1998 ELSE
1999 DO jj=j1,j1+npiv-1
2000 buf_effsize = buf_effsize + 1
2001 buf_indx(buf_effsize) = iw(jj)
2002 IF (buf_effsize + 1 .GT. buf_maxsize) THEN
2003 CALL smumps_get_buf_indx_rhs()
2004 ENDIF
2005 ENDDO
2006 ENDIF
2007 ENDIF
2008 ENDDO
2009 IF ( buf_effsize .NE. 0 .AND. myid.NE.master )
2010 & CALL smumps_get_buf_indx_rhs()
2011 ENDIF
2012 IF (keep(350).EQ.2) THEN
2013 DEALLOCATE (buf_indx, buf_rhs_2)
2014 ELSE
2015 DEALLOCATE (buf_indx, buf_rhs)
2016 ENDIF
2017 RETURN
2018 CONTAINS
2019 SUBROUTINE smumps_get_buf_indx_rhs()
2020 CALL mpi_send(buf_indx, buf_effsize, mpi_integer,
2021 & master, scatterrhsi, comm, ierr )
2022 IF (keep(350).EQ.2) THEN
2023 CALL mpi_recv(buf_rhs_2, buf_effsize*nrhs,
2024 & mpi_real,
2025 & master,
2026 & scatterrhsr, comm, status, ierr )
2027!$ OMP_FLAG = .FALSE.
2028!$ CHUNK = NRHS
2029!$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN
2030!$ OMP_FLAG = .TRUE.
2031!$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2)
2032!$ ENDIF
2033!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX)
2034!$OMP& IF (OMP_FLAG)
2035 DO k = 1, nrhs
2036 DO i = 1, buf_effsize
2037 indx = posinrhscomp_fwd(buf_indx(i))
2038 rhscomp( indx, k ) =
2039 & buf_rhs_2( i+(k-1)*buf_effsize)
2040 ENDDO
2041 ENDDO
2042!$OMP END PARALLEL DO
2043 ELSE
2044 CALL mpi_recv(buf_rhs, buf_effsize*nrhs,
2045 & mpi_real,
2046 & master,
2047 & scatterrhsr, comm, status, ierr )
2048 DO i = 1, buf_effsize
2049 indx = posinrhscomp_fwd(buf_indx(i))
2050 DO k = 1, nrhs
2051 rhscomp( indx, k ) = buf_rhs( k, i )
2052 ENDDO
2053 ENDDO
2054 END IF
2055 buf_effsize = 0
2056 RETURN
2057 END SUBROUTINE smumps_get_buf_indx_rhs
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
min
#define min(a, b)
Definition macros.h:20
mpi_get_count
subroutine mpi_get_count(status, datatype, cnt, ierr)
Definition mpi.f:296
smumps_get_buf_indx_rhs
subroutine smumps_get_buf_indx_rhs()
Definition ssol_c.F:2020

◆ smumps_sol_c()

subroutine smumps_sol_c ( type ( smumps_root_struc ) root,
integer n,
real, dimension(la) a,
integer(8) la,
integer, dimension(liw) iw,
integer liw,
real, dimension(lwc) w,
integer(8) lwc,
integer, dimension(liww) iwcb,
integer liww,
integer nrhs,
integer, dimension(lna) na,
integer lna,
integer, dimension(keep(28)) ne_steps,
real, dimension(keep(133)) w2,
integer mtype,
integer, dimension(60) icntl,
logical, intent(in) from_pp,
integer, dimension(n) step,
integer, dimension(keep(28)) frere,
integer, dimension(keep(28)) dad,
integer, dimension(n) fils,
integer, dimension(keep(28)) ptrist,
integer(8), dimension(keep(28)) ptrfac,
integer, dimension(liw1) iw1,
integer liw1,
integer(8), dimension(liwk_ptracb) ptracb,
integer liwk_ptracb,
integer, dimension(keep(28)) procnode_steps,
integer slavef,
integer, dimension(80) info,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
real, dimension(230), intent(inout) dkeep,
integer comm_nodes,
integer myid,
integer myid_nodes,
integer, dimension(lbufr) bufr,
integer lbufr,
integer lbufr_bytes,
integer, dimension(keep(71)) istep_to_iniv2,
integer, dimension(slavef+2,max(1,keep(56))) tab_pos_in_pere,
integer ibeg_root_def,
integer iend_root_def,
integer iroot_def_rhs_col1,
real, dimension(lrhs_root) rhs_root,
integer(8) lrhs_root,
integer size_root,
integer master_root,
real, dimension(lrhscomp,nrhs) rhscomp,
integer lrhscomp,
integer, dimension(n) posinrhscomp_fwd,
integer, dimension(n) posinrhscomp_bwd,
integer, intent(in) nz_rhs,
integer, intent(in) nbcol_inbloc,
integer, intent(in) nrhs_orig,
integer, intent(in) jbeg_rhs,
integer, dimension(lstep2node), intent(in) step2node,
integer, intent(in) lstep2node,
integer, dimension(nz_rhs), intent(in) irhs_sparse,
integer, dimension(nbcol_inbloc+1), intent(in) irhs_ptr,
integer, intent(in) size_perm_rhs,
integer, dimension(size_perm_rhs), intent(in) perm_rhs,
integer, intent(in) size_uns_perm_inv,
integer, dimension(size_uns_perm_inv), intent(in) uns_perm_inv,
integer nb_fs_in_rhscomp_f,
integer nb_fs_in_rhscomp_tot,
logical, intent(in) do_nbsparse,
integer, dimension (lrhs_bounds), intent(inout) rhs_bounds,
integer, intent(in) lrhs_bounds,
integer, dimension( lpool_b_l0_omp ), intent(in) ipool_b_l0_omp,
integer, intent(in) lpool_b_l0_omp,
integer, dimension( lpool_a_l0_omp ), intent(in) ipool_a_l0_omp,
integer, intent(in) lpool_a_l0_omp,
integer, intent(in) l_virt_l0_omp,
integer, dimension( l_virt_l0_omp ), intent(in) virt_l0_omp,
integer, intent(in) l_phys_l0_omp,
integer, dimension( l_phys_l0_omp ), intent(inout) phys_l0_omp,
integer, dimension( l_phys_l0_omp ), intent(in) perm_l0_omp,
integer, dimension( l_phys_l0_omp + 1), intent(in) ptr_leafs_l0_omp,
integer, dimension( ll0_omp_mapping ), intent(in) l0_omp_mapping,
integer, intent(in) ll0_omp_mapping,
type (smumps_l0ompfac_t), dimension(ll0_omp_factors), intent(in) l0_omp_factors,
integer, intent(in) ll0_omp_factors )

Definition at line 14 of file ssol_c.F.

31 USE smumps_ooc
32 USE smumps_sol_es
33 USE smumps_sol_l0omp_m, ONLY : smumps_sol_l0omp_r,
34 & smumps_sol_l0omp_s
35 USE smumps_struc_def, ONLY : smumps_root_struc
36 & , smumps_l0ompfac_t
37 IMPLICIT NONE
38#if defined(V_T)
39 include 'VT.inc'
40#endif
41 TYPE ( SMUMPS_ROOT_STRUC ) :: root
42 INTEGER(8) :: LA
43 INTEGER(8) :: LWC
44 INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA
45 INTEGER ICNTL(60),INFO(80), KEEP(500)
46 REAL, intent(inout) :: DKEEP(230)
47 INTEGER(8) KEEP8(150)
48 INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW)
49 INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)),
50 & DAD(KEEP(28))
51 INTEGER(8) :: PTRFAC(KEEP(28))
52 INTEGER :: LIWK_PTRACB
53 INTEGER(8) :: PTRACB(LIWK_PTRACB)
54 INTEGER NRHS, LRHSCOMP, NB_FS_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT
55 REAL A(LA), W(LWC),
56 & W2(KEEP(133))
57 REAL :: RHSCOMP(LRHSCOMP,NRHS)
58 INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES
59 INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP_FWD(N),
60 & POSINRHSCOMP_BWD(N)
61 INTEGER LBUFR, LBUFR_BYTES
62 INTEGER BUFR(LBUFR)
63 INTEGER ISTEP_TO_INIV2(KEEP(71)),
64 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
65 INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1
66 INTEGER SIZE_ROOT, MASTER_ROOT
67 INTEGER(8) :: LRHS_ROOT
68 REAL RHS_ROOT(LRHS_ROOT)
69 LOGICAL, intent(in) :: FROM_PP
70 INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC, NRHS_ORIG
71 INTEGER, intent(in) :: SIZE_UNS_PERM_INV
72 INTEGER, intent(in) :: SIZE_PERM_RHS
73 INTEGER, intent(in) :: JBEG_RHS
74 INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS)
75 INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1)
76 INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS)
77 INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV)
78 INTEGER, intent(in) :: LStep2node
79 INTEGER, intent(in) :: Step2node(LStep2node)
80 LOGICAL, intent(in) :: DO_NBSPARSE
81 INTEGER, intent(in) :: LRHS_BOUNDS
82 INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS)
83 INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP
84 INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP )
85 INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP
86 INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP )
87 INTEGER, INTENT (IN) :: L_PHYS_L0_OMP
88 INTEGER, INTENT (INOUT) :: PHYS_L0_OMP( L_PHYS_L0_OMP )
89 INTEGER, INTENT (IN) :: L_VIRT_L0_OMP
90 INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP )
91 INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP )
92 INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1)
93 INTEGER, INTENT (IN) :: LL0_OMP_MAPPING
94 INTEGER, INTENT (IN) :: L0_OMP_MAPPING( LL0_OMP_MAPPING )
95 INTEGER, INTENT (IN) :: LL0_OMP_FACTORS
96 TYPE (SMUMPS_L0OMPFAC_T), INTENT(IN) ::
97 & L0_OMP_FACTORS(LL0_OMP_FACTORS)
98 INTEGER MP, LP, LDIAG
99 INTEGER K,I,II
100 INTEGER allocok
101 INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS
102 INTEGER MYLEAF_NOT_PRUNED
103 INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB
104 INTEGER MTYPE_LOC
105 INTEGER MODE_RHS_BOUNDS
106 INTEGER IERR
107 INTEGER(8) :: IAPOS
108 INTEGER IOLDPS,
109 & LOCAL_M,
110 & LOCAL_N
111#if defined(V_T)
112 INTEGER soln_c_class, forw_soln, back_soln, root_soln
113#endif
114 LOGICAL DOFORWARD, DOROOT, DOBACKWARD
115 LOGICAL :: DO_L0OMP_FWD, DO_L0OMP_BWD
116 LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED
117 INTEGER IROOT
118 LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL
119 LOGICAL SWITCH_OFF_ES
120 LOGICAL DUMMY_BOOL
121 INTEGER :: IDUMMY
122 INTEGER :: NBROOT_UNDER_L0
123 REAL, PARAMETER :: ZERO = 0.0e0
124 include 'mumps_headers.h'
125 INTEGER, DIMENSION(:), ALLOCATABLE :: nodes_RHS
126 INTEGER nb_nodes_RHS
127 INTEGER nb_prun_leaves
128 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves
129 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List
130 INTEGER nb_prun_nodes
131 INTEGER nb_prun_roots, JAM1
132 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots
133 INTEGER :: SIZE_TO_PROCESS
134 LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS
135 INTEGER ISTEP, INODE_PRINC
136 INTEGER :: INODE, ICHILD
137 LOGICAL AM1, DO_PRUN
138 LOGICAL Exploit_Sparsity
139 LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD
140 INTEGER :: OOC_FCT_TYPE_TMP
141 INTEGER :: MUMPS_OOC_GET_FCT_TYPE
142 EXTERNAL :: mumps_ooc_get_fct_type
143 DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot
144 INTEGER :: nb_sparse
145 INTEGER, EXTERNAL :: MUMPS_PROCNODE
146 LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR
147 myleaf = -1
148 lp = icntl(1)
149 mp = icntl(2)
150 ldiag = icntl(4)
151#if defined(V_T)
152 CALL vtclassdef( 'Soln_c',soln_c_class,ierr)
153 CALL vtfuncdef( 'forw_soln',soln_c_class,forw_soln,ierr)
154 CALL vtfuncdef( 'back_soln',soln_c_class,back_soln,ierr)
155 CALL vtfuncdef( 'root_soln',soln_c_class,root_soln,ierr)
156#endif
157 IF (.NOT. from_pp) THEN
158 CALL mumps_secdeb(time_fwd)
159 ENDIF
160 nstk_s = 1
161 ptricb = nstk_s + keep(28)
162 ipool = ptricb + keep(28)
163 lpool = na(1) + 1
164 ipanel_pos = ipool + lpool
165 IF (keep(201).EQ.1) THEN
166 lpanel_pos = keep(228)+1
167 ELSE
168 lpanel_pos = 1
169 ENDIF
170 IF (ipanel_pos + lpanel_pos -1 .ne. liw1 ) THEN
171 WRITE(*,*) myid, ": Internal Error 1 in SMUMPS_SOL_C",
172 & ipanel_pos, lpanel_pos, liw1
173 CALL mumps_abort()
174 ENDIF
175 doforward = .true.
176 dobackward= .true.
177 special_root_reached = .true.
178 switch_off_es = .false.
179 IF ( keep(111).NE.0 .OR. keep(252).NE.0 ) THEN
180 doforward = .false.
181 ENDIF
182 IF (keep(221).eq.1) dobackward = .false.
183 IF (keep(221).eq.2) doforward = .false.
184 IF ( keep(60).EQ.0 .AND.
185 & (
186 & (keep(38).NE.0 .AND. root%yes)
187 & .OR.
188 & (keep(20).NE.0 .AND. myid_nodes.EQ.master_root)
189 & )
190 & .AND. keep(252).EQ.0
191 & )
192 &THEN
193 doroot = .true.
194 ELSE
195 doroot = .false.
196 ENDIF
197 doroot_bwd_panel = doroot .AND. mtype.NE.1 .AND. keep(50).EQ.0
198 & .AND. keep(201).EQ.1
199 doroot_fwd_ooc = doroot .AND. .NOT.doroot_bwd_panel
200 am1 = (keep(237) .NE. 0)
201 exploit_sparsity = (keep(235) .NE. 0) .AND. (.NOT. am1)
202 do_prun = (exploit_sparsity.OR.am1)
203 IF (from_pp) THEN
204 exploit_sparsity = .false.
205 do_prun = .false.
206 IF ( am1 ) THEN
207 WRITE(*,*) "Internal error 2 in SMUMPS_SOL_C"
208 CALL mumps_abort()
209 ENDIF
210 ENDIF
211 do_l0omp_fwd= ( (keep(401).GT.0).AND.(keep(400).GT.0)
212 & .AND.doforward )
213 do_l0omp_fwd = do_l0omp_fwd .AND. keep(201).EQ.0
214 do_l0omp_bwd = ( (keep(401).GT.0).AND.(keep(400).GT.0)
215 & .AND.dobackward )
216 do_l0omp_bwd = do_l0omp_bwd .AND. keep(201).EQ.0
217 IF ( do_prun ) THEN
218 ALLOCATE (pruned_sons(keep(28)), stat=i)
219 IF(i.GT.0) THEN
220 info(1)=-13
221 info(2)=keep(28)
222 END IF
223 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
224 IF(info(1).LT.0) GOTO 500
225 ENDIF
226 IF ( do_prun
227 & .OR. do_l0omp_bwd
228 & ) THEN
229 size_to_process = keep(28)
230 ELSE
231 size_to_process = 1
232 ENDIF
233 ALLOCATE (to_process(size_to_process), stat=i)
234 IF(i.GT.0) THEN
235 info(1)=-13
236 info(2)=keep(28)
237 END IF
238 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
239 IF(info(1).LT.0) GOTO 500
240 IF ( doforward .AND. do_prun ) THEN
241 nb_prun_nodes = 0
242 nb_prun_roots = 0
243 pruned_sons(:) = -1
244 IF ( exploit_sparsity ) THEN
245 nb_nodes_rhs = 0
246 DO i = 1, nz_rhs
247 istep = abs( step(irhs_sparse(i)) )
248 inode_princ = step2node( istep )
249 IF ( pruned_sons(istep) .eq. -1) THEN
250 nb_nodes_rhs = nb_nodes_rhs +1
251 pruned_sons(istep) = 0
252 ENDIF
253 ENDDO
254 ALLOCATE(nodes_rhs(nb_nodes_rhs), stat = allocok)
255 IF(allocok.GT.0) THEN
256 info(1)=-13
257 info(2)=nb_nodes_rhs
258 END IF
259 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
260 IF(info(1).LT.0) GOTO 500
261 nb_nodes_rhs = 0
262 pruned_sons = -1
263 DO i = 1, nz_rhs
264 istep = abs( step(irhs_sparse(i)) )
265 inode_princ = step2node( istep )
266 IF ( pruned_sons(istep) .eq. -1) THEN
267 nb_nodes_rhs = nb_nodes_rhs +1
268 nodes_rhs(nb_nodes_rhs) = inode_princ
269 pruned_sons(istep) = 0
270 ENDIF
271 ENDDO
272 ELSE IF ( am1 ) THEN
273 nb_nodes_rhs = 0
274 DO i = 1, nbcol_inbloc
275 IF ( (irhs_ptr(i+1)-irhs_ptr(i)).EQ.0) cycle
276 IF ( (keep(242) .NE. 0 ).OR. (keep(243).NE.0) ) THEN
277 jam1 = perm_rhs(jbeg_rhs+i-1)
278 ELSE
279 jam1 = jbeg_rhs+i-1
280 ENDIF
281 istep = abs(step(jam1))
282 inode_princ = step2node(istep)
283 IF ( pruned_sons(istep) .eq. -1) THEN
284 nb_nodes_rhs = nb_nodes_rhs +1
285 pruned_sons(istep) = 0
286 ENDIF
287 ENDDO
288 ALLOCATE(nodes_rhs(nb_nodes_rhs), stat = allocok)
289 IF(allocok.GT.0) THEN
290 info(1)=-13
291 info(2)=nb_nodes_rhs
292 END IF
293 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
294 IF(info(1).LT.0) GOTO 500
295 nb_nodes_rhs = 0
296 pruned_sons = -1
297 DO i = 1, nbcol_inbloc
298 IF ( (irhs_ptr(i+1)-irhs_ptr(i)).EQ.0) cycle
299 IF ( (keep(242) .NE. 0 ).OR. (keep(243).NE.0) ) THEN
300 jam1 = perm_rhs(jbeg_rhs+i-1)
301 ELSE
302 jam1 = jbeg_rhs+i-1
303 ENDIF
304 istep = abs(step(jam1))
305 inode_princ = step2node(istep)
306 IF ( pruned_sons(istep) .eq. -1) THEN
307 nb_nodes_rhs = nb_nodes_rhs +1
308 nodes_rhs(nb_nodes_rhs) = inode_princ
309 pruned_sons(istep) = 0
310 ENDIF
311 ENDDO
312 ENDIF
313 CALL smumps_chain_prun_nodes(
314 & .false.,
315 & dad, keep(28),
316 & step, n,
317 & nodes_rhs, nb_nodes_rhs,
318 & pruned_sons, to_process,
319 & nb_prun_nodes, nb_prun_roots,
320 & nb_prun_leaves )
321 ALLOCATE(pruned_list(nb_prun_nodes), stat=allocok)
322 IF(allocok.GT.0) THEN
323 info(1)=-13
324 info(2)=nb_prun_nodes
325 END IF
326 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
327 IF(info(1).LT.0) GOTO 500
328 ALLOCATE(pruned_roots(nb_prun_roots), stat=allocok)
329 IF(allocok.GT.0) THEN
330 info(1)=-13
331 info(2)=nb_prun_roots
332 END IF
333 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
334 IF(info(1).LT.0) GOTO 500
335 ALLOCATE(pruned_leaves(nb_prun_leaves), stat=allocok)
336 IF(allocok.GT.0) THEN
337 info(1)=-13
338 info(2)=nb_prun_leaves
339 END IF
340 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
341 IF(info(1).LT.0) GOTO 500
342 CALL smumps_chain_prun_nodes(
343 & .true.,
344 & dad, keep(28),
345 & step, n,
346 & nodes_rhs, nb_nodes_rhs,
347 & pruned_sons, to_process,
348 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves,
349 & pruned_list, pruned_roots, pruned_leaves )
350 IF(allocated(nodes_rhs)) DEALLOCATE(nodes_rhs)
351 CALL smumps_ooc_set_states_es(n,
352 & keep(201), pruned_list, nb_prun_nodes,
353 & step)
354 IF ( keep(201) .GT. 0) THEN
355 ooc_fct_type_tmp=mumps_ooc_get_fct_type
356 & ('F',mtype,keep(201),keep(50))
357 ELSE
358 ooc_fct_type_tmp = -5959
359 ENDIF
360 CALL smumps_chain_prun_nodes_stats(
361 & myid_nodes, n, keep(28), keep(201), keep(485),
362 & keep8(31)+keep8(64),
363 & step, pruned_list, nb_prun_nodes, ooc_fct_type_tmp
364 & )
365 IF (do_nbsparse) THEN
366 nb_sparse = max(1,keep(497))
367 mode_rhs_bounds = 0
368 IF (exploit_sparsity) mode_rhs_bounds = 2
369 CALL smumps_initialize_rhs_bounds(
370 & step, n,
371 & irhs_ptr, nbcol_inbloc, irhs_sparse, nz_rhs,
372 & jbeg_rhs, perm_rhs, size_perm_rhs, keep(242), keep(243),
373 & uns_perm_inv, size_uns_perm_inv, keep(23),
374 & rhs_bounds, keep(28),
375 & nb_sparse, myid_nodes,
376 & mode_rhs_bounds)
377 CALL smumps_propagate_rhs_bounds(
378 & pruned_leaves, nb_prun_leaves,
379 & step, n, pruned_sons,
380 & dad, rhs_bounds, keep(28),
381 & myid_nodes, comm_nodes, keep(485),
382 & iw, liw, ptrist,keep(ixsz),ooc_fct_type_tmp,0,
383 & keep(50), keep(38))
384 END IF
385 special_root_reached = .false.
386 DO i= 1, nb_prun_roots
387 IF ( (pruned_roots(i).EQ.keep(38)).OR.
388 & (pruned_roots(i).EQ.keep(20)) ) THEN
389 special_root_reached = .true.
390 EXIT
391 ENDIF
392 ENDDO
393 DEALLOCATE(pruned_list)
394 ENDIF
395 IF (keep(201).GT.0) THEN
396 IF (doforward .OR. doroot_fwd_ooc) THEN
397 CALL smumps_solve_init_ooc_fwd(ptrfac,keep(28),mtype,
398 & a,la,doforward,ierr)
399 IF(ierr.LT.0)THEN
400 info(1)=ierr
401 info(2)=0
402 CALL mumps_abort()
403 ENDIF
404 ENDIF
405 ENDIF
406 IF (doforward) THEN
407 IF ( keep( 50 ) .eq. 0 ) THEN
408 mtype_loc = mtype
409 ELSE
410 mtype_loc = 1
411 ENDIF
412#if defined(v_t)
413 CALL vtbegin(forw_soln,ierr)
414#endif
415 IF ( .NOT. do_prun ) THEN
416 CALL mumps_init_nroot_dist(n, nbroot, myroot, myid_nodes,
417 & slavef, na, lna, keep, step, procnode_steps)
418 DO istep =1, keep(28)
419 iw1(nstk_s+istep-1) = ne_steps(istep)
420 ENDDO
421 ELSE
422 CALL mumps_nblocal_roots_or_leaves( n,
423 & nb_prun_roots, pruned_roots,
424 & myroot, myid_nodes, slavef, keep, step,
425 & procnode_steps )
426 IF (am1) THEN
427 DEALLOCATE(pruned_roots)
428 END IF
429 IF ((exploit_sparsity).AND.(nb_prun_roots.EQ.na(2))) THEN
430 DEALLOCATE(pruned_roots)
431 switch_off_es = .true.
432 ENDIF
433 DO istep = 1, keep(28)
434 iw1(nstk_s+istep-1) = pruned_sons(istep)
435 ENDDO
436 ENDIF
437 IF ( do_l0omp_fwd ) THEN
438 CALL smumps_sol_l0omp_r( n, mtype_loc, nrhs, liw, iw,
439 & iw1(ptricb), rhscomp, lrhscomp, posinrhscomp_fwd,
440 & step, frere, dad, fils, iw1(nstk_s),
441 & ptrist, ptrfac, info,
442 & keep, keep8, dkeep, procnode_steps, slavef,
443 & comm_nodes, myid_nodes,
444 & bufr, lbufr, lbufr_bytes,
445 & rhs_root, lrhs_root,
446 & istep_to_iniv2, tab_pos_in_pere,
447 & rhs_bounds, lrhs_bounds, do_nbsparse,
448 & from_pp,
449 & nbroot_under_l0,
450 & lpool_b_l0_omp, ipool_b_l0_omp,
451 & l_virt_l0_omp, virt_l0_omp,
452 & l_phys_l0_omp, phys_l0_omp,
453 & perm_l0_omp, ptr_leafs_l0_omp,
454 & l0_omp_mapping, ll0_omp_mapping,
455 & l0_omp_factors, ll0_omp_factors,
456 & do_prun, to_process
457 & )
458 myroot = myroot - nbroot_under_l0
459 IF ( do_prun ) THEN
460 myleaf_not_pruned = ipool_a_l0_omp(lpool_a_l0_omp)
461 DO i=1, myleaf_not_pruned
462 IF ( to_process( step( ipool_a_l0_omp(i) ))) THEN
463 iw1(ipool+myleaf-1) = ipool_a_l0_omp(i)
464 iw1(nstk_s+step(ipool_a_l0_omp(i))-1) = -99
465 ENDIF
466 ENDDO
467 DO i = 1, nb_prun_leaves
468 inode = pruned_leaves(i)
469 IF ( mumps_procnode(procnode_steps(step(inode)),keep(199))
470 & .EQ. myid_nodes ) THEN
471 IF (l0_omp_mapping( step(inode) ) .EQ. 0) THEN
472 iw1(nstk_s+step(inode)-1) = -99
473 ENDIF
474 ENDIF
475 ENDDO
476 DO i = 1, l_phys_l0_omp
477 inode = dad(step(phys_l0_omp(i)))
478 IF (inode .NE. 0) THEN
479 IF ( to_process( step( inode ))) THEN
480 IF ( iw1(nstk_s+step(inode)-1) .EQ. 0 ) THEN
481 iw1(nstk_s+step(inode)-1) = -99
482 ENDIF
483 ENDIF
484 ENDIF
485 ENDDO
486 myleaf = 0
487 DO istep = keep(28), 1, -1
488 inode=step2node(istep)
489 IF (iw1(nstk_s+step(inode)-1).EQ.-99) THEN
490 myleaf = myleaf + 1
491 iw1(ipool+myleaf-1) = inode
492 iw1(nstk_s+step(inode)-1) = 0
493 ENDIF
494 ENDDO
495 DEALLOCATE(pruned_leaves)
496 ELSE
497 myleaf = ipool_a_l0_omp(lpool_a_l0_omp)
498 DO i=1, myleaf
499 iw1(ipool+i-1) = ipool_a_l0_omp(i)
500 ENDDO
501 ENDIF
502 ELSE
503 IF ( do_prun ) THEN
504 CALL mumps_init_pool_dist_nona( n, myleaf, myid_nodes,
505 & nb_prun_leaves, pruned_leaves, keep, keep8,
506 & step, procnode_steps, iw1(ipool), lpool )
507 myleaf = myleaf - 1
508 DEALLOCATE(pruned_leaves)
509 ELSE
510 CALL mumps_init_pool_dist( n, myleaf, myid_nodes,
511 & slavef, na, lna, keep, keep8, step,
512 & procnode_steps, iw1(ipool), lpool )
513 myleaf = myleaf - 1
514 ENDIF
515 ENDIF
516 CALL smumps_sol_r(n, a(1), la, iw(1), liw, w(1),
517 & lwc, nrhs,
518 & iw1(ptricb), iwcb, liww,
519 & rhscomp,lrhscomp,posinrhscomp_fwd,
520 & step, frere,dad,fils,
521 & iw1(nstk_s),iw1(ipool),lpool,ptrist,ptrfac,
522 & myleaf, myroot, info,
523 & keep, keep8, dkeep,
524 & procnode_steps, slavef, comm_nodes, myid_nodes,
525 & bufr, lbufr, lbufr_bytes,
526 & rhs_root, lrhs_root, mtype_loc,
527 &
528 & istep_to_iniv2, tab_pos_in_pere
529 & , rhs_bounds, lrhs_bounds, do_nbsparse, from_pp
530 & , l0_omp_mapping, ll0_omp_mapping,
531 & l0_omp_factors, ll0_omp_factors
532 & )
533 IF (do_prun) THEN
534 myleaf = -1
535 ENDIF
536#if defined(V_T)
537 CALL vtend(forw_soln,ierr)
538#endif
539 ENDIF
540 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
541 IF ( info(1) .LT. 0 ) THEN
542 IF ( lp .GT. 0 ) THEN
543 WRITE(lp,*) myid,
544 & ': ** ERROR RETURN FROM SMUMPS_SOL_R,INFO(1:2)=',
545 & info(1:2)
546 END IF
547 GOTO 500
548 END IF
549 CALL mpi_barrier( comm_nodes, ierr )
550 IF (.NOT.from_pp) THEN
551 CALL mumps_secfin(time_fwd)
552 dkeep(117)=real(time_fwd) + dkeep(117)
553 ENDIF
554 IF (do_prun.AND.switch_off_es) THEN
555 do_prun = .false.
556 exploit_sparsity = .false.
557 IF (.NOT. do_l0omp_bwd ) THEN
558 IF ( allocated(to_process) .AND. size_to_process.NE.1 ) THEN
559 DEALLOCATE (to_process)
560 size_to_process = 1
561 ALLOCATE(to_process(size_to_process),stat=i)
562 ENDIF
563 ENDIF
564 ENDIF
565 IF ( dobackward .AND. do_prun ) THEN
566 nb_prun_leaves = 0
567 IF ( exploit_sparsity .AND. (keep(111).EQ.0) ) THEN
568 nb_nodes_rhs = nb_prun_roots
569 ALLOCATE(nodes_rhs(nb_nodes_rhs), stat = allocok)
570 IF(allocok.GT.0) THEN
571 WRITE(*,*)'Problem with allocation of nodes_RHS'
572 info(1) = -13
573 info(2) = nb_nodes_rhs
574 CALL mumps_abort()
575 END IF
576 nodes_rhs(1:nb_prun_roots)=pruned_roots(1:nb_prun_roots)
577 DEALLOCATE(pruned_roots)
578 ELSE
579 nb_nodes_rhs = 0
580 pruned_sons(:) = -1
581 DO ii = 1, nz_rhs
582 i = irhs_sparse(ii)
583 IF (keep(23).NE.0) i = uns_perm_inv(i)
584 istep = abs(step(i))
585 IF ( pruned_sons(istep) .eq. -1) THEN
586 nb_nodes_rhs = nb_nodes_rhs +1
587 pruned_sons(istep) = 0
588 ENDIF
589 ENDDO
590 ALLOCATE(nodes_rhs(nb_nodes_rhs), stat = allocok)
591 IF(allocok.GT.0) THEN
592 WRITE(*,*)'Problem with allocation of nodes_RHS'
593 info(1) = -13
594 info(2) = nb_nodes_rhs
595 CALL mumps_abort()
596 END IF
597 nb_nodes_rhs = 0
598 pruned_sons(:) = -1
599 DO ii = 1, nz_rhs
600 i = irhs_sparse(ii)
601 IF (keep(23).NE.0) i = uns_perm_inv(i)
602 istep = abs(step(i))
603 inode_princ = step2node(istep)
604 IF ( pruned_sons(istep) .eq. -1) THEN
605 nb_nodes_rhs = nb_nodes_rhs +1
606 nodes_rhs(nb_nodes_rhs) = inode_princ
607 pruned_sons(istep) = 0
608 ENDIF
609 ENDDO
610 ENDIF
611 IF ( exploit_sparsity ) THEN
612 CALL smumps_tree_prun_nodes(
613 & .false.,
614 & dad, ne_steps, frere, keep(28),
615 & fils, step, n,
616 & nodes_rhs, nb_nodes_rhs,
617 & to_process,
618 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves
619 & )
620 ALLOCATE(pruned_list(nb_prun_nodes), stat=allocok)
621 IF(allocok.GT.0) THEN
622 info(1)=-13
623 info(2)=nb_prun_nodes
624 END IF
625 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
626 IF(info(1).LT.0) GOTO 500
627 ALLOCATE(pruned_roots(nb_prun_roots), stat=allocok)
628 IF(allocok.GT.0) THEN
629 info(1)=-13
630 info(2)=nb_prun_roots
631 END IF
632 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
633 IF(info(1).LT.0) GOTO 500
634 ALLOCATE(pruned_leaves(nb_prun_leaves), stat=allocok)
635 IF(allocok.GT.0) THEN
636 info(1)=-13
637 info(2)=nb_prun_leaves
638 END IF
639 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
640 IF(info(1).LT.0) GOTO 500
641 CALL smumps_tree_prun_nodes(
642 & .true.,
643 & dad, ne_steps, frere, keep(28),
644 & fils, step, n,
645 & nodes_rhs, nb_nodes_rhs,
646 & to_process,
647 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves,
648 & pruned_list, pruned_roots, pruned_leaves
649 & )
650 CALL smumps_ooc_set_states_es(n,
651 & keep(201), pruned_list, nb_prun_nodes,
652 & step)
653 IF(allocated(nodes_rhs)) DEALLOCATE(nodes_rhs)
654 IF (keep(201).GT.0) THEN
655 ooc_fct_type_tmp=mumps_ooc_get_fct_type
656 & ('B',mtype,keep(201),keep(50))
657 ELSE
658 ooc_fct_type_tmp = -5959
659 ENDIF
660 CALL smumps_tree_prun_nodes_stats(
661 & myid_nodes, n, keep(28), keep(201),
662 & keep8(31)+keep8(64),
663 & step,
664 & pruned_list,
665 & nb_prun_nodes, ooc_fct_type_tmp)
666 ENDIF
667 ENDIF
668 IF(keep(201).EQ.1.AND.doroot_bwd_panel) THEN
669 i_worked_on_root = .false.
670 CALL smumps_solve_init_ooc_bwd(ptrfac,keep(28),mtype,
671 & i_worked_on_root, iroot, a, la, ierr)
672 IF (ierr .LT. 0) THEN
673 info(1) = -90
674 info(2) = ierr
675 ENDIF
676 ENDIF
677 IF (keep(201).EQ.1) THEN
678 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
679 IF ( info(1) .LT. 0 ) GOTO 500
680 ENDIF
681 IF (keep(60).NE.0 .AND. keep(221).EQ.0
682 & .AND. myid_nodes .EQ. master_root) THEN
683 rhs_root(1:nrhs*size_root) = zero
684 ENDIF
685 IF (.NOT. from_pp) THEN
686 CALL mumps_secdeb(time_specialroot)
687 ENDIF
688 IF ( ( keep( 38 ) .NE. 0 ).AND. special_root_reached ) THEN
689 IF ( keep(60) .EQ. 0 .AND. keep(252) .EQ. 0 ) THEN
690 IF ( root%yes ) THEN
691 IF (keep(201).GT.0) THEN
692 IF ( (exploit_sparsity.AND.(keep(111).NE.0)) .and.
693 & (ooc_state_node(step(keep(38))).eq.-6) ) THEN
694 GOTO 1010
695 ENDIF
696 ENDIF
697 ioldps = ptrist(step(keep(38)))
698 local_m = iw( ioldps + 2 + keep(ixsz))
699 local_n = iw( ioldps + 1 + keep(ixsz))
700 IF (keep(201).GT.0) THEN
701 CALL smumps_solve_get_ooc_node(
702 & keep(38),ptrfac,keep,a,la,
703 & step,keep8,n,dummy_bool,ierr)
704 IF(ierr.LT.0)THEN
705 info(1)=ierr
706 info(2)=0
707 WRITE(*,*) '** ERROR after SMUMPS_SOLVE_GET_OOC_NODE',
708 & info(1)
709 call mumps_abort()
710 ENDIF
711 ENDIF
712 iapos = ptrfac(iw( ioldps + 4 + keep(ixsz)))
713 IF (local_m * local_n .EQ. 0) THEN
714 iapos = min(iapos, la)
715 ENDIF
716#if defined(V_T)
717 CALL vtbegin(root_soln,ierr)
718#endif
719 CALL smumps_root_solve( nrhs, root%DESCRIPTOR(1),
720 & root%CNTXT_BLACS, local_m, local_n,
721 & root%MBLOCK, root%NBLOCK,
722 & root%IPIV(1), root%LPIV, master_root, myid_nodes,
723 & comm_nodes,
724 & rhs_root(1),
725 & root%TOT_ROOT_SIZE, a( iapos ),
726 & info(1), mtype, keep(50), from_pp)
727 IF(keep(201).GT.0)THEN
728 CALL smumps_free_factors_for_solve(keep(38),
729 & ptrfac,keep(28),a,la,.false.,ierr)
730 IF(ierr.LT.0)THEN
731 info(1)=ierr
732 info(2)=0
733 WRITE(*,*)
734 & '** ERROR after SMUMPS_FREE_FACTORS_FOR_SOLVE ',
735 & info(1)
736 call mumps_abort()
737 ENDIF
738 ENDIF
739 ENDIF
740 ENDIF
741 ELSE IF ( ( keep(20) .NE. 0) .AND. special_root_reached ) THEN
742 IF ( myid_nodes .eq. master_root ) THEN
743 END IF
744 END IF
745 IF (.NOT.from_pp) THEN
746 CALL mumps_secfin(time_specialroot)
747 dkeep(119)=real(time_specialroot) + dkeep(119)
748 ENDIF
749#if defined(V_T)
750 CALL vtend(root_soln,ierr)
751#endif
752 1010 CONTINUE
753 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
754 IF ( info(1) .LT. 0 ) RETURN
755 IF (dobackward) THEN
756 IF ( keep(201).GT.0 .AND. .NOT. doroot_bwd_panel )
757 & THEN
758 i_worked_on_root = doroot
759 IF (keep(38).gt.0 ) THEN
760 IF ( ( exploit_sparsity.AND.(keep(111).EQ.0) )
761 & .OR. am1 ) THEN
762 IF (ooc_state_node(step(keep(38))).eq.-6) THEN
763 ooc_state_node(step(keep(38)))=-4
764 ENDIF
765 ENDIF
766 IF (exploit_sparsity.AND.(keep(111).NE.0)) THEN
767 IF (ooc_state_node(step(keep(38))).eq.-6) THEN
768 i_worked_on_root = .false.
769 ENDIF
770 ENDIF
771 ENDIF
772 ENDIF
773 IF (.NOT.am1) THEN
774 do_nbsparse_bwd = .false.
775 ELSE
776 do_nbsparse_bwd = do_nbsparse
777 ENDIF
778 prun_below_bwd = am1
779 prun_below_bwd = prun_below_bwd .OR. do_l0omp_bwd
780 IF ( am1 ) THEN
781 CALL smumps_chain_prun_nodes(
782 & .false.,
783 & dad, keep(28),
784 & step, n,
785 & nodes_rhs, nb_nodes_rhs,
786 & pruned_sons, to_process,
787 & nb_prun_nodes, nb_prun_roots,
788 & nb_prun_leaves)
789 ALLOCATE(pruned_list(nb_prun_nodes), stat=allocok)
790 IF(allocok.GT.0) THEN
791 info(1)=-13
792 info(2)=nb_prun_nodes
793 END IF
794 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
795 IF(info(1).LT.0) GOTO 500
796 ALLOCATE(pruned_roots(nb_prun_roots), stat=allocok)
797 IF(allocok.GT.0) THEN
798 info(1)=-13
799 info(2)=nb_prun_roots
800 END IF
801 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
802 IF(info(1).LT.0) GOTO 500
803 ALLOCATE(pruned_leaves(nb_prun_leaves), stat=allocok)
804 IF(allocok.GT.0) THEN
805 info(1)=-13
806 info(2)=nb_prun_leaves
807 END IF
808 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
809 IF(info(1).LT.0) GOTO 500
810 CALL smumps_chain_prun_nodes(
811 & .true.,
812 & dad, keep(28),
813 & step, n,
814 & nodes_rhs, nb_nodes_rhs,
815 & pruned_sons, to_process,
816 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves,
817 & pruned_list, pruned_roots, pruned_leaves )
818 CALL smumps_ooc_set_states_es(n,
819 & keep(201), pruned_list, nb_prun_nodes,
820 & step)
821 IF (keep(201).GT.0) THEN
822 ooc_fct_type_tmp=mumps_ooc_get_fct_type
823 & ('B',mtype,keep(201),keep(50))
824 ELSE
825 ooc_fct_type_tmp = -5959
826 ENDIF
827 CALL smumps_chain_prun_nodes_stats(
828 & myid_nodes, n, keep(28), keep(201), keep(485), keep8(31),
829 & step, pruned_list, nb_prun_nodes, ooc_fct_type_tmp
830 & )
831 IF (do_nbsparse_bwd) THEN
832 nb_sparse = max(1,keep(497))
833 CALL smumps_initialize_rhs_bounds(
834 & step, n,
835 & irhs_ptr, nbcol_inbloc, irhs_sparse, nz_rhs,
836 & jbeg_rhs, perm_rhs, size_perm_rhs, keep(242), keep(243),
837 & uns_perm_inv, size_uns_perm_inv, keep(23),
838 & rhs_bounds, keep(28),
839 & nb_sparse, myid_nodes,
840 & 1)
841 CALL smumps_propagate_rhs_bounds(
842 & pruned_leaves, nb_prun_leaves,
843 & step, n, pruned_sons,
844 & dad, rhs_bounds, keep(28),
845 & myid_nodes, comm_nodes, keep(485),
846 & iw, liw, ptrist,keep(ixsz),ooc_fct_type_tmp,1,
847 & keep(50), keep(38))
848 END IF
849 ENDIF
850 IF ( keep(201).GT.0 ) THEN
851 iroot = max(keep(20),keep(38))
852 CALL smumps_solve_init_ooc_bwd(ptrfac,keep(28),mtype,
853 & i_worked_on_root, iroot, a, la, ierr)
854 ENDIF
855 IF ( keep( 50 ) .eq. 0 ) THEN
856 mtype_loc = mtype
857 ELSE
858 mtype_loc = 0
859 ENDIF
860#if defined(V_T)
861 CALL vtbegin(back_soln,ierr)
862#endif
863 IF (.NOT.from_pp) THEN
864 CALL mumps_secdeb(time_bwd)
865 ENDIF
866 IF ( .NOT.special_root_reached ) THEN
867 rhs_root(1:nrhs*size_root) = zero
868 ENDIF
869 IF (am1.AND.(nb_fs_in_rhscomp_f.NE.nb_fs_in_rhscomp_tot)) THEN
870 DO i =1, n
871 ii = posinrhscomp_bwd(i)
872 IF ((ii.GT.0).AND.(ii.GT.nb_fs_in_rhscomp_f)) THEN
873 DO k=1,nrhs
874 rhscomp(ii, k) = zero
875 ENDDO
876 ENDIF
877 ENDDO
878 ENDIF
879 IF ( .NOT. do_prun ) THEN
880 IF ( .NOT. do_l0omp_bwd ) THEN
881 IF (do_l0omp_fwd) THEN
882 myleaf = -1
883 ENDIF
884 ENDIF
885 IF ( do_l0omp_bwd ) THEN
886 to_process(:) = .true.
887 DO i=1, l_phys_l0_omp
888 to_process( step(phys_l0_omp( i )))
889 & = .false.
890 ENDDO
891 IF (myleaf .EQ. -1) THEN
892 myleaf = ipool_a_l0_omp(lpool_a_l0_omp)
893 ENDIF
894 CALL mumps_init_pool_dist_na_bwd_l0( n, myroot, myid_nodes,
895 & na, lna, keep, keep8, step, procnode_steps,
896 & iw1(ipool), lpool, l0_omp_mapping )
897 ELSE
898 CALL mumps_init_pool_dist_na_bwd( n, myroot, myid_nodes,
899 & na, lna, keep, keep8, step, procnode_steps,
900 & iw1(ipool), lpool )
901 IF (myleaf .EQ. -1) THEN
902 CALL mumps_nblocal_roots_or_leaves( n,
903 & na(1),
904 & na(3),
905 & myleaf, myid_nodes, slavef, keep, step,
906 & procnode_steps )
907 ENDIF
908 ENDIF
909 ELSE
910 IF ( do_l0omp_bwd ) THEN
911 DO i=1, l_phys_l0_omp
912 IF ( to_process( step(phys_l0_omp( i ))) ) THEN
913 to_process( step(phys_l0_omp( i ))) = .false.
914 phys_l0_omp( i ) = -phys_l0_omp( i )
915 ENDIF
916 ENDDO
917 myleaf=0
918 DO istep = 1, keep(28)
919 IF ( mumps_procnode(procnode_steps(istep),keep(199))
920 & .NE. myid_nodes ) THEN
921 cycle
922 ENDIF
923 IF ( l0_omp_mapping( istep ) .NE. 0 ) THEN
924 cycle
925 ENDIF
926 IF ( .NOT. to_process( istep ) ) THEN
927 cycle
928 ENDIF
929 i = step2node( istep )
930 ichild = fils( i )
931 DO WHILE ( ichild .GT. 0 )
932 ichild = fils( ichild )
933 END DO
934 IF ( ichild .LT. 0 ) THEN
935 ichild = -ichild
936 DO WHILE ( ichild .GT. 0 )
937 IF ( l0_omp_mapping( step( ichild ) ) .EQ. 0 .AND.
938 & to_process(step( ichild )) ) THEN
939 GOTO 10
940 ENDIF
941 ichild = frere( step( ichild ) )
942 ENDDO
943 ENDIF
944 myleaf = myleaf + 1
945 10 CONTINUE
946 ENDDO
947 CALL mumps_init_pool_dist_na_bwdl0es( n, myroot,
948 & myid_nodes,
949 & na, lna, keep, keep8, step, procnode_steps,
950 & iw1(ipool), lpool, l0_omp_mapping, to_process )
951 ELSE
952 CALL mumps_init_pool_dist_bwd(n, nb_prun_roots,
953 & pruned_roots,
954 & myroot, myid_nodes, keep, keep8, step, procnode_steps,
955 & iw1(ipool), lpool)
956 CALL mumps_nblocal_roots_or_leaves( n,
957 & nb_prun_leaves, pruned_leaves,
958 & myleaf, myid_nodes, slavef, keep, step,
959 & procnode_steps )
960 ENDIF
961 ENDIF
962 IF ( do_l0omp_bwd
963 & ) THEN
964 keep(31) = 1
965 ELSE
966 keep(31) = 0
967 ENDIF
968 IF (keep(31) .EQ. 1) THEN
969 DO i = 1, keep(28)
970 IF (mumps_procnode(procnode_steps(i),keep(199)) .EQ.
971 & myid_nodes) THEN
972 IF ( .NOT. mumps_in_or_root_ssarbr(procnode_steps(i),
973 & keep(199)) ) THEN
974 IF ( l0_omp_mapping(i) .EQ. 0 ) THEN
975 IF ( do_prun
976 & .OR. do_l0omp_bwd
977 & ) THEN
978 IF ( to_process(i) ) THEN
979 keep(31) = keep(31) + 1
980 ENDIF
981 ELSE
982 keep(31) = keep(31) + 1
983 ENDIF
984 ENDIF
985 ENDIF
986 ENDIF
987 ENDDO
988 ENDIF
989 CALL smumps_sol_s( n, a, la, iw, liw, w(1), lwc,
990 & nrhs,
991 & rhscomp, lrhscomp, posinrhscomp_bwd,
992 & iw1(ptricb),ptracb,iwcb,liww, w2,
993 & ne_steps,
994 & step, frere,dad,fils,
995 & iw1(ipool),lpool,ptrist,ptrfac,myleaf,myroot,icntl,info,
996 & procnode_steps, slavef, comm_nodes, myid_nodes,
997 & bufr, lbufr, lbufr_bytes, keep, keep8, dkeep,
998 & rhs_root, lrhs_root,
999 & mtype_loc,
1000 & istep_to_iniv2, tab_pos_in_pere, iw1(ipanel_pos),
1001 & lpanel_pos, prun_below_bwd, to_process, size_to_process
1002 & , rhs_bounds, lrhs_bounds, do_nbsparse_bwd
1003 & , from_pp
1004 & , l0_omp_mapping, ll0_omp_mapping,
1005 & l0_omp_factors, ll0_omp_factors
1006 & )
1007 IF ( do_l0omp_bwd .AND. do_prun ) THEN
1008 DO i = 1, l_phys_l0_omp
1009 IF ( phys_l0_omp( i ) .LT. 0 ) THEN
1010 phys_l0_omp( i ) = -phys_l0_omp( i )
1011 to_process(step(phys_l0_omp( i ) )) = .true.
1012 ENDIF
1013 ENDDO
1014 ENDIF
1015 IF (do_l0omp_bwd .AND. info(1) .GE. 0) THEN
1016 keep(31) = 0
1017 prun_below_bwd = am1
1018 CALL smumps_sol_l0omp_s(n, mtype_loc, nrhs, liw, iw,
1019 & iw1(ptricb), ptracb, rhscomp, lrhscomp, posinrhscomp_bwd,
1020 & step, frere, fils, ne_steps, ptrist, ptrfac, info,
1021 & keep, keep8, dkeep, procnode_steps, slavef,
1022 & comm_nodes, myid_nodes, bufr, lbufr, lbufr_bytes,
1023 & rhs_root, lrhs_root, istep_to_iniv2, tab_pos_in_pere,
1024 & iw1(ipanel_pos), lpanel_pos,
1025 & prun_below_bwd, to_process, size_to_process,
1026 & rhs_bounds, lrhs_bounds, do_nbsparse_bwd,
1027 & from_pp,
1028 & lpool_b_l0_omp,
1029 & l_virt_l0_omp, virt_l0_omp,
1030 & l_phys_l0_omp, phys_l0_omp,
1031 & perm_l0_omp, ptr_leafs_l0_omp,
1032 & l0_omp_mapping, ll0_omp_mapping,
1033 & l0_omp_factors, ll0_omp_factors )
1034 ENDIF
1035 CALL smumps_clean_pending( info(1), keep,
1036 & bufr, lbufr,lbufr_bytes,
1037 & comm_nodes, idummy,
1038 & slavef, .true., .false. )
1039 CALL mumps_propinfo(icntl, info, comm_nodes, myid )
1040#if defined(V_T)
1041 CALL vtend(back_soln,ierr)
1042#endif
1043 IF (.NOT.from_pp) THEN
1044 CALL mumps_secfin(time_bwd)
1045 dkeep(118)=real(time_bwd)+dkeep(118)
1046 ENDIF
1047 ENDIF
1048 IF (ldiag.GT.2 .AND. mp.GT.0) THEN
1049 IF (doforward) THEN
1050 k = min0(10,size(rhscomp,1))
1051 IF (ldiag.EQ.4) k = size(rhscomp,1)
1052 IF ( .NOT. from_pp) THEN
1053 WRITE (mp,99992)
1054 IF (size(rhscomp,1).GT.0)
1055 & WRITE (mp,99993) (rhscomp(i,1),i=1,k)
1056 IF (size(rhscomp,1).GT.0.and.nrhs>1)
1057 & WRITE (mp,99994) (rhscomp(i,2),i=1,k)
1058 ENDIF
1059 ENDIF
1060 ENDIF
1061500 CONTINUE
1062 IF ( allocated(to_process)) DEALLOCATE (to_process)
1063 IF (exploit_sparsity.OR.am1.OR.switch_off_es) THEN
1064 IF ( allocated(nodes_rhs)) DEALLOCATE (nodes_rhs)
1065 IF ( allocated(pruned_sons)) DEALLOCATE (pruned_sons)
1066 IF ( allocated(pruned_roots)) DEALLOCATE (pruned_roots)
1067 IF ( allocated(pruned_list)) DEALLOCATE (pruned_list)
1068 IF ( allocated(pruned_leaves)) DEALLOCATE (pruned_leaves)
1069 ENDIF
1070 RETURN
107199993 FORMAT (' RHS (internal, first column)'/(1x,1p,5e14.6))
107299994 FORMAT (' RHS (internal, 2 nd column)'/(1x,1p,5e14.6))
107399992 FORMAT (//' LEAVING SOLVE (SMUMPS_SOL_C) WITH')
mpi_barrier
subroutine mpi_barrier(comm, ierr)
Definition mpi.f:188
mumps_ooc_get_fct_type
integer function mumps_ooc_get_fct_type(fwdorbwd, mtype, k201, k50)
Definition mumps_ooc_common.F:97
smumps_ooc
Definition smumps_ooc.F:14
smumps_ooc::ooc_state_node
integer, dimension(:), allocatable ooc_state_node
Definition smumps_ooc.F:49
smumps_ooc::smumps_solve_init_ooc_fwd
subroutine, public smumps_solve_init_ooc_fwd(ptrfac, nsteps, mtype, a, la, doprefetch, ierr)
Definition smumps_ooc.F:2707
smumps_ooc::smumps_free_factors_for_solve
subroutine smumps_free_factors_for_solve(inode, ptrfac, nsteps, a, la, flag, ierr)
Definition smumps_ooc.F:1204
smumps_ooc::smumps_ooc_set_states_es
subroutine smumps_ooc_set_states_es(n, keep201, pruned_list, nb_prun_nodes, step)
Definition smumps_ooc.F:3451
smumps_ooc::smumps_solve_init_ooc_bwd
subroutine, public smumps_solve_init_ooc_bwd(ptrfac, nsteps, mtype, i_worked_on_root, iroot, a, la, ierr)
Definition smumps_ooc.F:2744
smumps_sol_es
Definition smumps_sol_es.F:14
smumps_sol_es::smumps_tree_prun_nodes_stats
subroutine, public smumps_tree_prun_nodes_stats(myid, n, keep28, keep201, fr_fact, step, pruned_list, nb_prun_nodes, ooc_fct_type_loc)
Definition smumps_sol_es.F:417
smumps_sol_es::smumps_tree_prun_nodes
subroutine, public 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)
Definition smumps_sol_es.F:48
smumps_sol_es::smumps_chain_prun_nodes
subroutine, public 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)
Definition smumps_sol_es.F:139
smumps_sol_es::smumps_chain_prun_nodes_stats
subroutine, public smumps_chain_prun_nodes_stats(myid, n, keep28, keep201, keep485, fr_fact, step, pruned_list, nb_prun_nodes, ooc_fct_type_loc)
Definition smumps_sol_es.F:439
smumps_sol_es::smumps_propagate_rhs_bounds
subroutine, public 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)
Definition smumps_sol_es.F:269
smumps_sol_es::smumps_initialize_rhs_bounds
subroutine, public 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)
Definition smumps_sol_es.F:215
smumps_sol_l0omp_m
Definition ssol_omp_m.F:14
smumps_sol_l0omp_m::smumps_sol_l0omp_s
subroutine smumps_sol_l0omp_s(n, mtype, nrhs, liw, iw, ptricb, ptracb, rhscomp, lrhscomp, posinrhscomp_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)
Definition ssol_omp_m.F:299
smumps_sol_l0omp_m::smumps_sol_l0omp_r
subroutine smumps_sol_l0omp_r(n, mtype, nrhs, liw, iw, ptricb, rhscomp, lrhscomp, posinrhscomp_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)
Definition ssol_omp_m.F:62
smumps_struc_def
Definition smumps_struc_def.F:14
smumps_clean_pending
subroutine smumps_clean_pending(info1, keep, bufr, lbufr, lbufr_bytes, comm_nodes, comm_load, slavef, clean_comm_nodes, clean_comm_load)
Definition sfac_process_message.F:819
smumps_solve_get_ooc_node
subroutine smumps_solve_get_ooc_node(inode, ptrfac, keep, a, la, step, keep8, n, must_be_permuted, ierr)
Definition ssol_aux.F:732
smumps_sol_s
subroutine smumps_sol_s(n, a, la, iw, liw, w, lwc, nrhs, rhscomp, lrhscomp, posinrhscomp_bwd, ptricb, ptracb, iwcb, liww, w2, ne_steps, step, frere, dad, fils, ipool, lpool, ptrist, ptrfac, myleaf, myroot, icntl, info, procnode_steps, slavef, comm, myid, bufr, lbufr, lbufr_bytes, keep, keep8, dkeep, rhs_root, lrhs_root, mtype, istep_to_iniv2, tab_pos_in_pere, panel_pos, lpanel_pos, prun_below, to_process, size_to_process, rhs_bounds, lrhs_bounds, do_nbsparse, from_pp, l0_omp_mapping, ll0_omp_mapping, l0_omp_factors, ll0_omp_factors)
Definition ssol_bwd.F:31
smumps_sol_r
subroutine smumps_sol_r(n, a, la, iw, liw, wcb, lwcb, nrhs, ptricb, iwcb, liwcb, rhscomp, lrhscomp, posinrhscomp_fwd, step, frere, dad, fils, nstk, ipool, lpool, ptrist, ptrfac, myleaf, myroot, info, keep, keep8, dkeep, procnode_steps, slavef, comm, myid, bufr, lbufr, lbufr_bytes, rhs_root, lrhs_root, mtype, istep_to_iniv2, tab_pos_in_pere, rhs_bounds, lrhs_bounds, do_nbsparse, from_pp, l0_omp_mapping, ll0_omp_mapping, l0_omp_factors, ll0_omp_factors)
Definition ssol_fwd.F:32
smumps_root_solve
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)
Definition ssol_root_parallel.F:18
mumps_nblocal_roots_or_leaves
subroutine mumps_nblocal_roots_or_leaves(n, nbrorl, rorl_list, nrorl_loc, myid_nodes, slavef, keep, step, procnode_steps)
Definition tools_common.F:669
mumps_secfin
subroutine mumps_secfin(t)
Definition tools_common.F:277
mumps_init_pool_dist_na_bwd_l0
subroutine mumps_init_pool_dist_na_bwd_l0(n, myroot, myid_nodes, na, lna, keep, keep8, step, procnode_steps, ipool, lpool, l0_omp_mapping)
Definition tools_common.F:524
mumps_in_or_root_ssarbr
logical function mumps_in_or_root_ssarbr(procinfo_inode, k199)
Definition tools_common.F:214
mumps_init_pool_dist
subroutine mumps_init_pool_dist(n, leaf, myid_nodes, k199, na, lna, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:587
mumps_init_pool_dist_bwd
subroutine mumps_init_pool_dist_bwd(n, nb_prun_roots, pruned_roots, myroot, myid_nodes, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:443
mumps_init_pool_dist_na_bwdl0es
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)
Definition tools_common.F:554
mumps_init_pool_dist_nona
subroutine mumps_init_pool_dist_nona(n, leaf, myid_nodes, lleaves, leaves, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:614
mumps_init_pool_dist_na_bwd
subroutine mumps_init_pool_dist_na_bwd(n, myroot, myid_nodes, na, lna, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:498
mumps_secdeb
subroutine mumps_secdeb(t)
Definition tools_common.F:270
mumps_init_nroot_dist
subroutine mumps_init_nroot_dist(n, nbroot, nroot_loc, myid_nodes, slavef, na, lna, keep, step, procnode_steps)
Definition tools_common.F:639