OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dmumps_parallel_analysis Module Reference

Data Types

interface  dmumps_ana_f_par
type  ord_type
type  graph_type
type  arrpnt

Functions/Subroutines

subroutine, public dmumps_ana_f_par (id, work1, work2, nfsiz, fils, frere)
subroutine dmumps_set_par_ord (id, ord)
subroutine dmumps_do_par_ord (id, ord, work)
logical function dmumps_stop_descent (id, ord, nactive, anode, rproc, alist, list, peakmem, nnodes, checkmem)
integer function dmumps_cnt_kids (node, ord)
subroutine dmumps_get_subtrees (ord, id)
subroutine dmumps_parsymfact (id, ord, gpe, gnv, work)
subroutine dmumps_make_loc_idx (id, topnodes, lperm, liperm, ord)
subroutine dmumps_assemble_top_graph (id, nlocvars, lperm, top_graph, ncliques, lstvar, lvarpt, ipe, pe, leng, elen)
subroutine dmumps_build_loc_graph (id, ord, gsize, ipe, pe, leng, i_halo_map, top_graph, work)
subroutine dmumps_send_buf (apnt, proc, nprocs, bufsize, ipe, pe, leng, rcvbuf, msgcnt, sndcnt, comm)
subroutine dmumps_assemble_msg (bufsize, rcvbuf, ipe, pe, leng)
subroutine dmumps_mergeswap (n, l, a1, a2)
subroutine dmumps_mergesort (n, k, l)
integer function mumps_getsize (a)

Variables

integer mp
integer mpg
integer lp
integer nrl
integer toprows
integer(8) memcnt
integer(8) maxmem
logical prok
logical prokg
logical lpok

Function/Subroutine Documentation

◆ dmumps_ana_f_par()

subroutine, public dmumps_parallel_analysis::dmumps_ana_f_par ( type(dmumps_struc) id,
integer, dimension(:), target work1,
integer, dimension(:), target work2,
integer, dimension(:) nfsiz,
integer, dimension(:) fils,
integer, dimension(:) frere )

Definition at line 53 of file dana_aux_par.F.

55 USE dmumps_struc_def
56 IMPLICIT NONE
57 TYPE(DMUMPS_STRUC) :: id
58 INTEGER, TARGET :: WORK1(:), WORK2(:)
59 INTEGER :: NFSIZ(:), FILS(:), FRERE(:)
60 TYPE(ORD_TYPE) :: ord
61 INTEGER, POINTER :: IPE(:), NV(:),
62 & NE(:), NA(:), NODE(:),
63 & ND(:), SUBORD(:), NAMALG(:),
64 & IPS(:), CUMUL(:),
65 & SAVEIRN(:), SAVEJCN(:)
66 INTEGER :: MYID, NPROCS, IERR, NEMIN, LDIAG
67 LOGICAL :: SPLITROOT
68 INTEGER(8), PARAMETER :: K79REF=12000000_8
69 INTEGER, PARAMETER :: LIDUMMY = 1
70 INTEGER :: IDUMMY(1)
71 DOUBLE PRECISION :: TIMEB
72 nullify(ipe, nv, ne, na, node, nd, subord, namalg, ips,
73 & cumul, saveirn, savejcn)
74 CALL mpi_comm_rank (id%COMM, myid, ierr)
75 CALL mpi_comm_size (id%COMM, nprocs, ierr)
76 lp = id%ICNTL(1)
77 mp = id%ICNTL(2)
78 mpg = id%ICNTL(3)
79 prok = (mp.GT.0)
80 prokg = (mpg.GT.0) .AND. (myid .EQ. 0)
81 lpok = (lp.GT.0) .AND. (id%ICNTL(4).GE.1)
82 ldiag = id%ICNTL(4)
83 ord%PERMTAB => work1(1 : id%N)
84 ord%PERITAB => work1(id%N+1 : 2*id%N)
85 ord%TREETAB => work1(2*id%N+1 : 3*id%N)
86 IF(id%KEEP(54) .NE. 3) THEN
87 IF(myid.EQ.0) THEN
88 saveirn => id%IRN_loc
89 savejcn => id%JCN_loc
90 id%IRN_loc => id%IRN
91 id%JCN_loc => id%JCN
92 id%KEEP8(29) = id%KEEP8(28)
93 ELSE
94 id%KEEP8(29)=0_8
95 END IF
96 END IF
97 maxmem=0
98 IF(memcnt .GT. maxmem) maxmem=memcnt
99 CALL dmumps_set_par_ord(id, ord)
100 id%INFOG(7) = id%KEEP(245)
101 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
102 & id%COMM, id%MYID )
103 IF ( id%INFO(1) .LT. 0 ) RETURN
104 IF (prokg) CALL mumps_secdeb( timeb )
105 CALL dmumps_do_par_ord(id, ord, work2)
106 IF (prokg) THEN
107 CALL mumps_secfin( timeb )
108 WRITE(mpg,
109 & '(" ELAPSED time in parallel ordering =",F12.4)')
110 & timeb
111 ENDIF
112 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
113 & id%COMM, id%MYID )
114 IF ( id%INFO(1) .LT. 0 ) RETURN
115 IF(id%MYID .EQ. 0) THEN
116 CALL mumps_realloc(ipe, id%N, id%INFO, lp, force=.false.,
117 & copy=.false., string='',
118 & memcnt=memcnt, errcode=-7)
119 CALL mumps_realloc(nv, id%N, id%INFO, lp,
120 & memcnt=memcnt, errcode=-7)
121 IF(memcnt .GT. maxmem) maxmem=memcnt
122 END IF
123 ord%SUBSTRAT = 0
124 ord%TOPSTRAT = 0
125 CALL dmumps_parsymfact(id, ord, ipe, nv, work2)
126 IF(id%KEEP(54) .NE. 3) THEN
127 IF(myid.EQ.0) THEN
128 id%IRN_loc => saveirn
129 id%JCN_loc => savejcn
130 END IF
131 END IF
132 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
133 & id%COMM, id%MYID )
134 IF ( id%INFO(1) .LT. 0 ) RETURN
135 NULLIFY(ord%PERMTAB)
136 NULLIFY(ord%PERITAB)
137 NULLIFY(ord%TREETAB)
138 CALL mumps_idealloc(ord%FIRST, ord%LAST, memcnt=memcnt)
139 IF (myid .EQ. 0) THEN
140 ips => work1(1:id%N)
141 ne => work1(id%N+1 : 2*id%N)
142 na => work1(2*id%N+1 : 3*id%N)
143 node => work2(1 : id%N )
144 nd => work2(id%N+1 : 2*id%N)
145 subord => work2(2*id%N+1 : 3*id%N)
146 namalg => work2(3*id%N+1 : 4*id%N)
147 CALL mumps_realloc(cumul, id%N, id%INFO, lp,
148 & string='CUMUL', memcnt=memcnt, errcode=-7)
149 IF(memcnt .GT. maxmem) maxmem=memcnt
150 nemin = id%KEEP(1)
151 CALL dmumps_ana_lnew(id%N, ipe(1), nv(1), ips(1), ne(1),
152 & na(1), nfsiz(1), node(1), id%INFOG(6), fils(1), frere(1),
153 & nd(1), nemin, subord(1), id%KEEP(60), id%KEEP(20),
154 & id%KEEP(38), namalg(1), id%KEEP(104), cumul(1),
155 & id%KEEP(50), id%ICNTL(13), id%KEEP(37), id%KEEP(197),
156 & id%NSLAVES, id%KEEP(250).EQ.1, .false., idummy, lidummy)
157 CALL mumps_dealloc(cumul, nv, ipe, memcnt=memcnt)
158 CALL dmumps_ana_m(ne(1), nd(1), id%INFOG(6), id%INFOG(5),
159 & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108),
160 & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253))
161 IF ( id%KEEP(53) .NE. 0 ) THEN
162 CALL mumps_make1root(id%N, frere(1), fils(1), nfsiz(1),
163 & id%KEEP(20))
164 END IF
165 IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8)
166 & .OR.
167 & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 )
168 & .OR.
169 & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN
170 CALL dmumps_set_k821_surface(id%KEEP8(21), id%KEEP(2),
171 & id%KEEP(48), id%KEEP(50), id%NSLAVES)
172 END IF
173 IF ((id%KEEP(210).LT.0) .OR. (id%KEEP(210).GT.2))
174 & id%KEEP(210)=0
175 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).GT.0))
176 & id%KEEP(210)=1
177 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).EQ.0))
178 & id%KEEP(210)=2
179 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79))
180 IF ((id%KEEP(210).EQ.1) .AND. (id%KEEP8(79).LE.0_8)) THEN
181 id%KEEP8(79)=k79ref * int(id%NSLAVES,8)
182 ENDIF
183 IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR.
184 & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR.
185 & (id%KEEP(79).EQ.6)
186 & ) THEN
187 IF (id%KEEP(210).EQ.1) THEN
188 splitroot = .false.
189 IF ( id%KEEP(62).GE.1) THEN
190 idummy(1) = -1
191 CALL dmumps_cutnodes(id%N, frere(1), fils(1),
192 & nfsiz(1), idummy, lidummy, id%INFOG(6),
193 & id%NSLAVES, id%KEEP(1), id%KEEP8(1), splitroot,
194 & mp, ldiag, id%INFOG(1), id%INFOG(2))
195 IF (id%INFOG(1).LT.0) RETURN
196 ENDIF
197 ENDIF
198 ENDIF
199 splitroot = (((id%ICNTL(13).GT.0) .AND.
200 & (id%NSLAVES.GT.id%ICNTL(13))) .OR.
201 & (id%ICNTL(13).EQ.-1)) .AND. (id%KEEP(60).EQ.0)
202 IF (splitroot) THEN
203 idummy(1) = -1
204 CALL dmumps_cutnodes(id%N, frere(1), fils(1), nfsiz(1),
205 & idummy, lidummy, id%INFOG(6),
206 & id%NSLAVES, id%KEEP(1), id%KEEP8(1),
207 & splitroot, mp, ldiag, id%INFOG(1), id%INFOG(2))
208 IF (id%INFOG(1).LT.0) RETURN
209 ENDIF
210 END IF
211 RETURN
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
dmumps_ana_m
subroutine dmumps_ana_m(ne, nd, nsteps, maxfr, maxelim, k50, sizefac_tot, maxnpiv, k5, k6, panel_size, k253)
Definition dana_aux.F:2780
dmumps_cutnodes
subroutine dmumps_cutnodes(n, frere, fils, nfsiz, sizeofblocks, lsizeofblocks, nsteps, nslaves, keep, keep8, splitroot, mp, ldiag, info1, info2)
Definition dana_aux.F:2919
dmumps_set_k821_surface
subroutine dmumps_set_k821_surface(keep821, keep2, keep48, keep50, nslaves)
Definition dana_aux.F:3554
dmumps_ana_lnew
subroutine dmumps_ana_lnew(n, ipe, nv, ips, ne, na, nfsiz, node, nsteps, fils, frere, nd, nemin, subord, keep60, keep20, keep38, namalg, namalgmax, cumul, keep50, icntl13, keep37, keep197, nslaves, allow_amalg_tiny_nodes, blkon, sizeofblocks, lsizeofblocks)
Definition dana_aux.F:2412
mpi_comm_size
subroutine mpi_comm_size(comm, size, ierr)
Definition mpi.f:263
mpi_comm_rank
subroutine mpi_comm_rank(comm, rank, ierr)
Definition mpi.f:254
id
initmumps id
Definition multiplerhs_example.m:4
dmumps_struc_def
Definition dmumps_struc_def.F:14
mumps_secfin
subroutine mumps_secfin(t)
Definition tools_common.F:277
mumps_secdeb
subroutine mumps_secdeb(t)
Definition tools_common.F:270
mumps_make1root
subroutine mumps_make1root(n, frere, fils, nfsiz, theroot)
Definition tools_common.F:32

◆ dmumps_assemble_msg()

subroutine dmumps_parallel_analysis::dmumps_assemble_msg ( integer bufsize,
integer, dimension(:) rcvbuf,
integer(8), dimension(:) ipe,
integer, dimension(:) pe,
integer, dimension(:) leng )
private

Definition at line 2039 of file dana_aux_par.F.

2040 IMPLICIT NONE
2041 INTEGER :: BUFSIZE
2042 INTEGER :: RCVBUF(:), PE(:), LENG(:)
2043 INTEGER(8) :: IPE(:)
2044 INTEGER :: I, ROW, COL
2045 DO i=1, 2*bufsize, 2
2046 row = rcvbuf(i)
2047 col = rcvbuf(i+1)
2048 pe(ipe(row)+leng(row)) = col
2049 leng(row) = leng(row) + 1
2050 END DO
2051 RETURN

◆ dmumps_assemble_top_graph()

subroutine dmumps_parallel_analysis::dmumps_assemble_top_graph ( type(dmumps_struc) id,
integer nlocvars,
integer, dimension(:), pointer lperm,
type(graph_type) top_graph,
integer ncliques,
integer, dimension(:), pointer lstvar,
integer(8), dimension(:) lvarpt,
integer(8), dimension(:), pointer ipe,
integer, dimension(:), pointer pe,
integer, dimension(:), pointer leng,
integer, dimension(:), pointer elen )
private

Definition at line 1234 of file dana_aux_par.F.

1236 IMPLICIT NONE
1237 TYPE(DMUMPS_STRUC) :: id
1238 TYPE(GRAPH_TYPE) :: top_graph
1239 INTEGER, POINTER :: LPERM(:), LSTVAR(:),
1240 & PE(:), LENG(:), ELEN(:)
1241 INTEGER(8) :: LVARPT(:)
1242 INTEGER :: NCLIQUES
1243 INTEGER(8), POINTER :: IPE(:)
1244 INTEGER :: I, IDX, NLOCVARS
1245 INTEGER(8) :: INNZ, PNT, SAVEPNT
1246 CALL mumps_realloc(leng, max(nlocvars+ncliques,1) , id%INFO,
1247 & lp, string='ATG:LENG', memcnt=memcnt, errcode=-7)
1248 CALL mumps_realloc(elen, max(nlocvars+ncliques,1) , id%INFO,
1249 & lp, string='ATG:ELEN', memcnt=memcnt, errcode=-7)
1250 CALL mumps_i8realloc(ipe , nlocvars+ncliques+1, id%INFO,
1251 & lp, string='ATG:IPE', memcnt=memcnt, errcode=-7)
1252 IF(memcnt .GT. maxmem) maxmem=memcnt
1253 leng = 0
1254 elen = 0
1255 DO innz=1, top_graph%NZ_LOC
1256 IF((lperm(top_graph%JCN_LOC(innz)) .NE. 0) .AND.
1257 & (top_graph%JCN_LOC(innz) .NE. top_graph%IRN_LOC(innz)))
1258 & THEN
1259 leng(lperm(top_graph%IRN_LOC(innz))) =
1260 & leng(lperm(top_graph%IRN_LOC(innz))) + 1
1261 END IF
1262 END DO
1263 DO i=1, ncliques
1264 DO innz=lvarpt(i), lvarpt(i+1)-1
1265 elen(lperm(lstvar(innz))) = elen(lperm(lstvar(innz)))+1
1266 leng(nlocvars+i) = leng(nlocvars+i)+1
1267 END DO
1268 END DO
1269 ipe(1) = 1
1270 DO i=1, nlocvars+ncliques
1271 ipe(i+1) = ipe(i)+int(leng(i),8)+int(elen(i),8)
1272 END DO
1273 CALL mumps_irealloc8(pe, ipe(nlocvars+ncliques+1)+
1274 & int(nlocvars,8)+int(ncliques,8),
1275 & id%INFO, lp, string='ATG:PE', memcnt=memcnt, errcode=-7)
1276 IF(memcnt .GT. maxmem) maxmem=memcnt
1277 leng = 0
1278 elen = 0
1279 DO i=1, ncliques
1280 DO innz=lvarpt(i), lvarpt(i+1)-1
1281 idx = lperm(lstvar(innz))
1282 pe(ipe(idx)+int(elen(idx),8)) = nlocvars+i
1283 pe(ipe(nlocvars+i)+int(leng(nlocvars+i),8)) = idx
1284 elen(lperm(lstvar(innz))) = elen(lperm(lstvar(innz)))+1
1285 leng(nlocvars+i) = leng(nlocvars+i)+1
1286 end do
1287 end do
1288 DO innz=1, top_graph%NZ_LOC
1289 IF((lperm(top_graph%JCN_LOC(innz)) .NE. 0) .AND.
1290 & (top_graph%JCN_LOC(innz) .NE. top_graph%IRN_LOC(innz)))
1291 & THEN
1292 pe(ipe(lperm(top_graph%IRN_LOC(innz)))+
1293 & elen(lperm(top_graph%IRN_LOC(innz))) +
1294 & leng(lperm(top_graph%IRN_LOC(innz)))) =
1295 & lperm(top_graph%JCN_LOC(innz))
1296 leng(lperm(top_graph%IRN_LOC(innz))) =
1297 & leng(lperm(top_graph%IRN_LOC(innz))) + 1
1298 END IF
1299 END DO
1300 DO i=1, nlocvars+ncliques
1301 leng(i) = leng(i)+elen(i)
1302 END DO
1303 savepnt = 1
1304 pnt = 0
1305 lperm(1:nlocvars+ncliques) = 0
1306 DO i=1, nlocvars+ncliques
1307 DO innz=ipe(i), ipe(i+1)-1
1308 IF(lperm(pe(innz)) .EQ. i) THEN
1309 leng(i) = leng(i)-1
1310 ELSE
1311 lperm(pe(innz)) = i
1312 pnt = pnt+1
1313 pe(pnt) = pe(innz)
1314 END IF
1315 END DO
1316 ipe(i) = savepnt
1317 savepnt = pnt+1
1318 END DO
1319 ipe(nlocvars+ncliques+1) = savepnt
1320 RETURN
max
#define max(a, b)
Definition macros.h:21

◆ dmumps_build_loc_graph()

subroutine dmumps_parallel_analysis::dmumps_build_loc_graph ( type(dmumps_struc) id,
type(ord_type) ord,
integer gsize,
integer(8), dimension(:), pointer ipe,
integer, dimension(:), pointer pe,
integer, dimension(:), pointer leng,
integer, dimension(:), pointer i_halo_map,
type(graph_type) top_graph,
integer, dimension(:), pointer work )
private

Definition at line 1588 of file dana_aux_par.F.

1590 IMPLICIT NONE
1591 TYPE(DMUMPS_STRUC) :: id
1592 TYPE(ORD_TYPE) :: ord
1593 TYPE(GRAPH_TYPE) :: top_graph
1594 INTEGER(8), POINTER :: IPE(:)
1595 INTEGER, POINTER :: PE(:), LENG(:),
1596 & I_HALO_MAP(:), WORK(:)
1597 INTEGER :: GSIZE
1598 INTEGER :: IERR, MYID, NPROCS
1599 INTEGER :: I, PROC, J, LOC_ROW
1600 INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX,
1601 & RCVPNT
1602 INTEGER :: IIDX,JJDX
1603 INTEGER :: HALO_SIZE, NROWS_LOC, DUPS
1604 INTEGER :: STATUS(MPI_STATUS_SIZE)
1605 INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:)
1606 INTEGER, POINTER :: MAPTAB(:),
1607 & HALO_MAP(:), BUFLEVEL(:)
1608 INTEGER, POINTER :: RDISPL(:),
1609 & SIPES(:,:)
1610 INTEGER, POINTER :: TSENDI(:),
1611 & TSENDJ(:), RCVBUF(:)
1612 TYPE(ARRPNT), POINTER :: APNT(:)
1613 INTEGER :: BUFSIZE, SOURCE, MAXS, allocok
1614 INTEGER(8) :: PNT, SAVEPNT
1615 INTEGER, PARAMETER :: ITAG=30
1616 INTEGER(KIND=8) :: TLEN
1617 LOGICAL :: FLAG
1618 nullify(maptab, sndcnt, rcvcnt, halo_map)
1619 nullify(rdispl, msgcnt, sipes, buflevel)
1620 nullify(tsendi, tsendj, rcvbuf, apnt)
1621 CALL mpi_comm_rank (id%COMM, myid, ierr)
1622 CALL mpi_comm_size (id%COMM, nprocs, ierr)
1623 IF(mumps_getsize(work) .LT. id%N*2) THEN
1624 WRITE(lp,
1625 & '("Insufficient workspace inside BUILD_LOC_GRAPH")')
1626 CALL mumps_abort()
1627 END IF
1628 maptab => work( 1 : id%N)
1629 halo_map => work(id%N+1 : 2*id%N)
1630 CALL mumps_i8realloc(sndcnt, nprocs, id%INFO, lp,
1631 & memcnt=memcnt, errcode=-7)
1632 CALL mumps_i8realloc(rcvcnt, nprocs, id%INFO, lp,
1633 & memcnt=memcnt, errcode=-7)
1634 CALL mumps_i8realloc(msgcnt, nprocs, id%INFO, lp,
1635 & memcnt=memcnt, errcode=-7)
1636 CALL mumps_realloc(rdispl, nprocs, id%INFO, lp,
1637 & memcnt=memcnt, errcode=-7)
1638 IF(memcnt .GT. maxmem) maxmem=memcnt
1639 ALLOCATE(apnt(nprocs), stat=allocok)
1640 IF(allocok.GT.0) THEN
1641 id%INFO(1)=-13
1642 id%INFO(2)=nprocs
1643 ENDIF
1644 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
1645 IF ( id%INFO(1) .LT. 0 ) GO TO 90
1646 sndcnt = 0
1647 top_cnt = 0
1648 bufsize = 10000
1649 locnnz = id%KEEP8(29)
1650 nrows_loc = ord%LAST(myid+1)-ord%FIRST(myid+1)+1
1651 maptab = 0
1652 maxs = 0
1653 DO i=1, nprocs
1654 IF((ord%LAST(i)-ord%FIRST(i)+1) .GT. maxs) THEN
1655 maxs = ord%LAST(i)-ord%FIRST(i)+1
1656 END IF
1657 DO j=ord%FIRST(i), ord%LAST(i)
1658 maptab(ord%PERITAB(j)) = i
1659 END DO
1660 END DO
1661 ALLOCATE(sipes(max(1,maxs), nprocs), stat=allocok)
1662 IF(allocok.GT.0) THEN
1663 id%INFO(1)=-13
1664 id%INFO(2)=max(1,maxs)*nprocs
1665 ENDIF
1666 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
1667 IF ( id%INFO(1) .LT. 0 ) GO TO 90
1668 sipes(:,:) = 0
1669 top_cnt = 0
1670 DO innz=1, locnnz
1671 IF(id%IRN_loc(innz) .NE. id%JCN_loc(innz)) THEN
1672 proc = maptab(id%IRN_loc(innz))
1673 IF(proc .EQ. 0) THEN
1674 top_cnt = top_cnt+1
1675 ELSE
1676 iidx = ord%PERMTAB(id%IRN_loc(innz))
1677 loc_row = iidx-ord%FIRST(proc)+1
1678 sipes(loc_row, proc) = sipes(loc_row, proc)+1
1679 sndcnt(proc) = sndcnt(proc)+1
1680 END IF
1681 proc = maptab(id%JCN_loc(innz))
1682 IF(proc .EQ. 0) THEN
1683 top_cnt = top_cnt+1
1684 ELSE
1685 iidx = ord%PERMTAB(id%JCN_loc(innz))
1686 loc_row = iidx-ord%FIRST(proc)+1
1687 sipes(loc_row, proc) = sipes(loc_row, proc)+1
1688 sndcnt(proc) = sndcnt(proc)+1
1689 END IF
1690 END IF
1691 END DO
1692 CALL mpi_alltoall(sndcnt(1), 1, mpi_integer8, rcvcnt(1), 1,
1693 & mpi_integer8, id%COMM, ierr)
1694 i = ceiling(dble(maxs)*1.20d0)
1695 CALL mumps_realloc(leng, max(i,1), id%INFO,
1696 & lp, string='B_L_G:LENG', memcnt=memcnt, errcode=-7)
1697 IF(memcnt .GT. maxmem) maxmem=memcnt
1698 CALL mumps_i8dealloc(sndcnt, memcnt=memcnt)
1699 rdispl(:) = maxs
1700 CALL mpi_reduce_scatter ( sipes(1,1), leng(1), rdispl(1),
1701 & mpi_integer, mpi_sum, id%COMM, ierr )
1702 DEALLOCATE(sipes)
1703 i = ceiling(dble(nrows_loc+1)*1.20d0)
1704 CALL mumps_i8realloc(ipe, max(i,1), id%INFO,
1705 & lp, string='B_L_G:IPE', memcnt=memcnt, errcode=-7)
1706 IF(memcnt .GT. maxmem) maxmem=memcnt
1707 tlen = 0_8
1708 ipe(1) = 1_8
1709 DO i=1, nrows_loc
1710 ipe(i+1) = ipe(i) + int(leng(i),8)
1711 tlen = tlen+int(leng(i),8)
1712 END DO
1713 CALL mumps_irealloc8(tsendi, max(top_cnt,1_8), id%INFO, lp,
1714 & memcnt=memcnt, errcode=-7)
1715 CALL mumps_irealloc8(tsendj, max(top_cnt,1_8), id%INFO, lp,
1716 & memcnt=memcnt, errcode=-7)
1717 IF(memcnt .GT. maxmem) maxmem=memcnt
1718 leng(:) = 0
1719 CALL mumps_realloc(buflevel, nprocs, id%INFO, lp,
1720 & memcnt=memcnt, errcode=-7)
1721 CALL dmumps_send_buf(apnt, proc, nprocs, bufsize, ipe, pe,
1722 & leng, rcvbuf, msgcnt, buflevel, id%COMM)
1723 new_locnnz = 0
1724 DO i=1, nprocs
1725 new_locnnz = new_locnnz + rcvcnt(i)
1726 msgcnt(i) = rcvcnt(i)/int(bufsize,8)
1727 END DO
1728 CALL mumps_irealloc8(pe, max(new_locnnz+
1729 & 2_8*int(nrows_loc+ord%TOPNODES(2),8),1_8),
1730 & id%INFO, lp, string='B_L_G:PE', memcnt=memcnt, errcode=-7)
1731 IF(memcnt .GT. maxmem) maxmem=memcnt
1732 rcvpnt = 1
1733 buflevel = 0
1734 tidx = 0
1735 DO innz=1, locnnz
1736 IF(mod(innz,int(bufsize/10,8)) .EQ. 0) THEN
1737 CALL mpi_iprobe( mpi_any_source, itag, id%COMM,
1738 & flag, status, ierr )
1739 IF(flag) THEN
1740 source = status(mpi_source)
1741 CALL mpi_recv(rcvbuf(1), 2*bufsize, mpi_integer, source,
1742 & itag, id%COMM, status, ierr)
1743 CALL dmumps_assemble_msg(bufsize, rcvbuf, ipe, pe, leng)
1744 msgcnt(source+1)=msgcnt(source+1)-1
1745 rcvpnt = rcvpnt + bufsize
1746 END IF
1747 END IF
1748 IF(id%IRN_loc(innz) .NE. id%JCN_loc(innz)) THEN
1749 proc = maptab(id%IRN_loc(innz))
1750 IF((maptab(id%JCN_loc(innz)).NE.proc) .AND.
1751 & (maptab(id%JCN_loc(innz)).NE.0) .AND.
1752 & (proc.NE.0)) THEN
1753 ierr = -50
1754 id%INFO(1) = ierr
1755 END IF
1756 IF(proc .EQ. 0) THEN
1757 tidx = tidx+1
1758 tsendi(tidx) = id%IRN_loc(innz)
1759 tsendj(tidx) = id%JCN_loc(innz)
1760 ELSE
1761 iidx = ord%PERMTAB(id%IRN_loc(innz))
1762 jjdx = ord%PERMTAB(id%JCN_loc(innz))
1763 apnt(proc)%BUF(2*buflevel(proc)+1)=iidx-ord%FIRST(proc)+1
1764 IF( (jjdx .GE. ord%FIRST(proc)) .AND.
1765 & (jjdx .LE. ord%LAST(proc)) ) THEN
1766 apnt(proc)%BUF(2*buflevel(proc)+2) =
1767 & jjdx-ord%FIRST(proc)+1
1768 ELSE
1769 apnt(proc)%BUF(2*buflevel(proc)+2) = -id%JCN_loc(innz)
1770 END IF
1771 buflevel(proc) = buflevel(proc)+1
1772 IF(buflevel(proc) .EQ. bufsize) THEN
1773 CALL dmumps_send_buf(apnt, proc, nprocs, bufsize, ipe,
1774 & pe, leng, rcvbuf, msgcnt, buflevel, id%COMM)
1775 END IF
1776 END IF
1777 proc = maptab(id%JCN_loc(innz))
1778 IF(proc .EQ. 0) THEN
1779 tidx = tidx+1
1780 tsendi(tidx) = id%JCN_loc(innz)
1781 tsendj(tidx) = id%IRN_loc(innz)
1782 ELSE
1783 iidx = ord%PERMTAB(id%JCN_loc(innz))
1784 jjdx = ord%PERMTAB(id%IRN_loc(innz))
1785 apnt(proc)%BUF(2*buflevel(proc)+1) =
1786 & iidx-ord%FIRST(proc)+1
1787 IF( (jjdx .GE. ord%FIRST(proc)) .AND.
1788 & (jjdx .LE. ord%LAST(proc)) ) THEN
1789 apnt(proc)%BUF(2*buflevel(proc)+2) =
1790 & jjdx-ord%FIRST(proc)+1
1791 ELSE
1792 apnt(proc)%BUF(2*buflevel(proc)+2) = -id%IRN_loc(innz)
1793 END IF
1794 buflevel(proc) = buflevel(proc)+1
1795 IF(buflevel(proc) .EQ. bufsize) THEN
1796 CALL dmumps_send_buf(apnt, proc, nprocs, bufsize, ipe,
1797 & pe, leng, rcvbuf, msgcnt, buflevel, id%COMM)
1798 END IF
1799 END IF
1800 END IF
1801 END DO
1802 CALL dmumps_send_buf(apnt, -1, nprocs, bufsize, ipe, pe, leng,
1803 & rcvbuf, msgcnt, buflevel, id%COMM)
1804 dups = 0
1805 pnt = 0
1806 savepnt = 1
1807 maptab(:) = 0
1808 halo_map(:) = 0
1809 halo_size = 0
1810 DO i=1, nrows_loc
1811 DO innz=ipe(i),ipe(i+1)-1
1812 IF(pe(innz) .LT. 0) THEN
1813 IF(halo_map(-pe(innz)) .EQ. 0) THEN
1814 halo_size = halo_size+1
1815 halo_map(-pe(innz)) = nrows_loc+halo_size
1816 END IF
1817 pe(innz) = halo_map(-pe(innz))
1818 END IF
1819 IF(maptab(pe(innz)) .EQ. i) THEN
1820 dups = dups+1
1821 leng(i) = leng(i)-1
1822 ELSE
1823 maptab(pe(innz)) = i
1824 pnt = pnt+1
1825 pe(pnt) = pe(innz)
1826 END IF
1827 END DO
1828 ipe(i) = savepnt
1829 savepnt = pnt+1
1830 END DO
1831 ipe(nrows_loc+1) = savepnt
1832 CALL mumps_realloc(i_halo_map, halo_size, id%INFO, lp,
1833 & memcnt=memcnt, errcode=-7)
1834 IF(memcnt .GT. maxmem) maxmem=memcnt
1835 j=0
1836 DO i=1, id%N
1837 IF(halo_map(i) .GT. 0) THEN
1838 j = j+1
1839 i_halo_map(halo_map(i)-nrows_loc) = i
1840 END IF
1841 IF(j .EQ. halo_size) EXIT
1842 END DO
1843 CALL mumps_realloc(leng, max(nrows_loc+halo_size,1), id%INFO,
1844 & lp, copy=.true.,
1845 & string='lcgrph:leng', memcnt=memcnt, errcode=-7)
1846 leng(nrows_loc+1:nrows_loc+halo_size) = 0
1847 CALL mumps_i8realloc(ipe, nrows_loc+halo_size+1, id%INFO,
1848 & lp, copy=.true.,
1849 & string='lcgrph:ipe', memcnt=memcnt, errcode=-7)
1850 IF(memcnt .GT. maxmem) maxmem=memcnt
1851 ipe(nrows_loc+2:nrows_loc+halo_size+1) = ipe(nrows_loc+1)
1852 gsize = nrows_loc + halo_size
1853 CALL mpi_gather(top_cnt, 1, mpi_integer8, rcvcnt(1), 1,
1854 & mpi_integer8, 0, id%COMM, ierr)
1855 IF(myid.EQ.0) THEN
1856 new_locnnz = sum(rcvcnt)
1857 top_graph%NZ_LOC = new_locnnz
1858 top_graph%COMM = id%COMM
1859 CALL mumps_irealloc8(top_graph%IRN_LOC, max(1_8,new_locnnz),
1860 & id%INFO, lp, memcnt=memcnt, errcode=-7)
1861 CALL mumps_irealloc8(top_graph%JCN_LOC, max(1_8,new_locnnz),
1862 & id%INFO, lp, memcnt=memcnt, errcode=-7)
1863 IF(memcnt .GT. maxmem) maxmem=memcnt
1864 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID)
1865 IF ( id%INFO(1) .LT. 0 ) GO TO 90
1866 ELSE
1867 ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1),
1868 & stat=allocok)
1869 IF(allocok.GT.0) THEN
1870 id%INFO(1)=-13
1871 id%INFO(2)=2
1872 ENDIF
1873 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID)
1874 IF ( id%INFO(1) .LT. 0 ) GO TO 90
1875 END IF
1876 IF(myid.EQ.0) THEN
1877 top_graph%IRN_LOC(1:top_cnt) = tsendi(1:top_cnt)
1878 top_graph%JCN_LOC(1:top_cnt) = tsendj(1:top_cnt)
1879 DO proc=2, nprocs
1880 DO WHILE (rcvcnt(proc) .GT. 0)
1881 i = int(min(int(bufsize,8), rcvcnt(proc)))
1882 CALL mpi_recv(top_graph%IRN_LOC(top_cnt+1), i,
1883 & mpi_integer, proc-1, itag, id%COMM, status, ierr)
1884 CALL mpi_recv(top_graph%JCN_LOC(top_cnt+1), i,
1885 & mpi_integer, proc-1, itag, id%COMM, status, ierr)
1886 rcvcnt(proc) = rcvcnt(proc)-i
1887 top_cnt = top_cnt+i
1888 END DO
1889 END DO
1890 ELSE
1891 DO WHILE (top_cnt .GT. 0)
1892 i = int(min(int(bufsize,8), top_cnt))
1893 CALL mpi_send(tsendi(top_cnt-i+1), i,
1894 & mpi_integer, 0, itag, id%COMM, ierr)
1895 CALL mpi_send(tsendj(top_cnt-i+1), i,
1896 & mpi_integer, 0, itag, id%COMM, ierr)
1897 top_cnt = top_cnt-i
1898 END DO
1899 END IF
1900 CALL mumps_dealloc(buflevel, rdispl, tsendi,
1901 & tsendj, memcnt=memcnt)
1902 CALL mumps_i8dealloc(msgcnt, sndcnt, rcvcnt, memcnt=memcnt)
1903 DEALLOCATE(apnt)
1904 90 continue
1905 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
min
#define min(a, b)
Definition macros.h:20
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_iprobe
subroutine mpi_iprobe(source, tag, comm, flag, status, ierr)
Definition mpi.f:360
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
mpi_alltoall
subroutine mpi_alltoall(sendbuf, sendcnt, sendtype, recvbuf, recvcnt, recvtype, comm, ierr)
Definition mpi.f:161
mpi_reduce_scatter
subroutine mpi_reduce_scatter(sendbuf, recvbuf, rcvcnt, datatype, op, comm, ierr)
Definition mpi.f:137
mpi_gather
subroutine mpi_gather(sendbuf, cnt, datatype, recvbuf, reccnt, rectype, root, comm, ierr)
Definition mpi.f:56

◆ dmumps_cnt_kids()

integer function dmumps_parallel_analysis::dmumps_cnt_kids ( integer node,
type(ord_type) ord )
private

Definition at line 713 of file dana_aux_par.F.

714 IMPLICIT NONE
715 INTEGER :: DMUMPS_CNT_KIDS
716 INTEGER :: NODE
717 TYPE(ORD_TYPE) :: ord
718 INTEGER :: CURR
719 dmumps_cnt_kids = 0
720 IF(ord%SON(node) .EQ. -1) THEN
721 RETURN
722 ELSE
723 dmumps_cnt_kids = 1
724 curr = ord%SON(node)
725 DO
726 IF(ord%BROTHER(curr) .NE. -1) THEN
727 dmumps_cnt_kids = dmumps_cnt_kids+1
728 curr = ord%BROTHER(curr)
729 ELSE
730 EXIT
731 END IF
732 END DO
733 END IF
734 RETURN

◆ dmumps_do_par_ord()

subroutine dmumps_parallel_analysis::dmumps_do_par_ord ( type(dmumps_struc) id,
type(ord_type) ord,
integer, dimension(:) work )
private

Definition at line 355 of file dana_aux_par.F.

356 IMPLICIT NONE
357 TYPE(DMUMPS_STRUC) :: id
358 TYPE(ORD_TYPE) :: ord
359 INTEGER :: WORK(:)
360#if defined(parmetis) || defined(parmetis3)
361 INTEGER :: IERR
362#endif
363 IF (ord%ORDTOOL .EQ. 1) THEN
364#if defined(ptscotch)
365 CALL dmumps_ptscotch_ord(id, ord, work)
366#else
367 id%INFOG(1) = -38
368 id%INFO(1) = -38
369 WRITE(lp,*)'PT-SCOTCH not available. Aborting...'
370 CALL mumps_abort()
371#endif
372 ELSE IF (ord%ORDTOOL .EQ. 2) THEN
373#if defined(parmetis) || defined(parmetis3)
374 CALL dmumps_parmetis_ord(id, ord, work)
375 if(ord%IDO) CALL mpi_comm_free(ord%COMM_NODES, ierr)
376#else
377 id%INFOG(1) = -38
378 id%INFO(1) = -38
379 WRITE(lp,*)'ParMETIS not available. Aborting...'
380 CALL mumps_abort()
381#endif
382 END IF
383 RETURN
mpi_comm_free
subroutine mpi_comm_free(comm, ierr)
Definition mpi.f:238

◆ dmumps_get_subtrees()

subroutine dmumps_parallel_analysis::dmumps_get_subtrees ( type(ord_type) ord,
type(dmumps_struc) id )
private

Definition at line 736 of file dana_aux_par.F.

737 IMPLICIT NONE
738 TYPE(ORD_TYPE) :: ord
739 TYPE(DMUMPS_STRUC) :: id
740 INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:)
741 INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I,
742 & NK, PEAKMEM, allocok
743 LOGICAL :: SD
744 nnodes = ord%NSLAVES
745 CALL mumps_realloc(ord%TOPNODES, 2*max(nnodes,2), id%INFO, lp,
746 & memcnt=memcnt, errcode=-7)
747 CALL mumps_realloc(ord%FIRST, id%NPROCS, id%INFO, lp,
748 & memcnt=memcnt, errcode=-7)
749 CALL mumps_realloc(ord%LAST, id%NPROCS, id%INFO, lp,
750 & memcnt=memcnt, errcode=-7)
751 IF(memcnt .GT. maxmem) maxmem=memcnt
752 ALLOCATE(alist(nnodes), aweights(nnodes), list(nnodes),
753 & work(0:nnodes+1), stat=allocok)
754 IF(allocok.GT.0) THEN
755 id%INFO(1)=-13
756 id%INFO(2)=4*nnodes+2
757 ENDIF
758 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID )
759 IF ( id%INFO(1) .LT. 0 ) GO TO 90
760 nactive = 0
761 DO i=1, ord%CBLKNBR
762 IF (ord%TREETAB(i).EQ.-1) THEN
763 nactive = nactive+1
764 IF(nactive.LE.nnodes) THEN
765 alist(nactive) = i
766 aweights(nactive) = ord%NW(i)
767 END IF
768 END IF
769 END DO
770 IF((ord%CBLKNBR .EQ. 1) .OR.
771 & (nactive.GT.nnodes) .OR.
772 & ( nnodes .LT. dmumps_cnt_kids(ord%CBLKNBR, ord) )) THEN
773 ord%TOPNODES(1) = 1
774 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1)
775 ord%TOPNODES(3) = ord%RANGTAB(1)
776 ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1
777 ord%FIRST = 0
778 ord%LAST = -1
779 RETURN
780 END IF
781 CALL dmumps_mergesort(nactive, aweights(1:nactive),
782 & work(0:nactive+1))
783 CALL dmumps_mergeswap(nactive, work(0:nactive+1),
784 & aweights(1:nactive),
785 & alist(1:nactive))
786 rproc = nnodes
787 anode = 0
788 peakmem = 0
789 ord%TOPNODES = 0
790 DO
791 IF(nactive .EQ. 0) EXIT
792 big = alist(nactive)
793 nk = dmumps_cnt_kids(big, ord)
794 IF((nk .GT. (rproc-nactive+1)) .OR. (nk .EQ. 0)) THEN
795 anode = anode+1
796 list(anode) = big
797 nactive = nactive-1
798 rproc = rproc-1
799 cycle
800 END IF
801 sd = dmumps_stop_descent(id, ord, nactive, anode,
802 & rproc, alist, list, peakmem, nnodes, checkmem=.true.)
803 IF ( sd )
804 & THEN
805 IF(nactive.GT.0) THEN
806 list(anode+1:anode+nactive) = alist(1:nactive)
807 anode = anode+nactive
808 END IF
809 EXIT
810 END IF
811 ord%TOPNODES(1) = ord%TOPNODES(1)+1
812 ord%TOPNODES(2) = ord%TOPNODES(2) +
813 & ord%RANGTAB(big+1) - ord%RANGTAB(big)
814 ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(big)
815 ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) =
816 & ord%RANGTAB(big+1)-1
817 curr = ord%SON(big)
818 alist(nactive) = curr
819 aweights(nactive) = ord%NW(curr)
820 DO
821 IF(ord%BROTHER(curr) .EQ. -1) EXIT
822 nactive = nactive+1
823 curr = ord%BROTHER(curr)
824 alist(nactive) = curr
825 aweights(nactive) = ord%NW(curr)
826 END DO
827 CALL dmumps_mergesort(nactive, aweights(1:nactive),
828 & work(0:nactive+1))
829 CALL dmumps_mergeswap(nactive, work(0:nactive+1),
830 & aweights(1:nactive),
831 & alist(1:nactive))
832 END DO
833 DO i=1, anode
834 aweights(i) = ord%NW(list(i))
835 END DO
836 CALL dmumps_mergesort(anode, aweights(1:anode), work(0:anode+1))
837 CALL dmumps_mergeswap(anode, work(0:anode+1), aweights(1:anode),
838 & alist(1:anode))
839 IF (id%KEEP(46) .EQ. 1) THEN
840 base = 0
841 ELSE
842 ord%FIRST(1) = 0
843 ord%LAST(1) = -1
844 base = 1
845 END IF
846 DO i=1, anode
847 curr = list(i)
848 nd = curr
849 IF(ord%SON(nd) .NE. -1) THEN
850 nd = ord%SON(nd)
851 DO
852 IF((ord%SON(nd) .EQ. -1) .AND.
853 & (ord%BROTHER(nd).EQ.-1)) THEN
854 EXIT
855 ELSE IF(ord%BROTHER(nd) .EQ. -1) THEN
856 nd = ord%SON(nd)
857 ELSE
858 nd = ord%BROTHER(nd)
859 END IF
860 END DO
861 END IF
862 ord%FIRST(base+i) = ord%RANGTAB(nd)
863 ord%LAST(base+i) = ord%RANGTAB(curr+1)-1
864 END DO
865 DO i=anode+1, id%NSLAVES
866 ord%FIRST(base+i) = id%N+1
867 ord%LAST(base+i) = id%N
868 END DO
869 DEALLOCATE(list, alist, aweights, work)
870 90 continue
871 RETURN

◆ dmumps_make_loc_idx()

subroutine dmumps_parallel_analysis::dmumps_make_loc_idx ( type(dmumps_struc) id,
integer, dimension(:), pointer topnodes,
integer, dimension(:), pointer lperm,
integer, dimension(:), pointer liperm,
type(ord_type) ord )
private

Definition at line 1211 of file dana_aux_par.F.

1212 IMPLICIT NONE
1213 TYPE(DMUMPS_STRUC) :: id
1214 INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:)
1215 TYPE(ORD_TYPE) :: ord
1216 INTEGER :: I, J, K, GIDX
1217 CALL mumps_realloc(lperm , ord%N, id%INFO,
1218 & lp, string='LIDX:LPERM', memcnt=memcnt, errcode=-7)
1219 CALL mumps_realloc(liperm, topnodes(2), id%INFO,
1220 & lp, string='LIDX:LIPERM', memcnt=memcnt, errcode=-7)
1221 IF(memcnt .GT. maxmem) maxmem=memcnt
1222 lperm = 0
1223 k = 1
1224 DO i=topnodes(1), 1, -1
1225 DO j=topnodes(2*i+1), topnodes(2*i+2)
1226 gidx = ord%PERITAB(j)
1227 lperm(gidx) = k
1228 liperm(k) = gidx
1229 k = k+1
1230 END DO
1231 END DO
1232 RETURN

◆ dmumps_mergesort()

subroutine dmumps_parallel_analysis::dmumps_mergesort ( integer n,
integer, dimension(:) k,
integer, dimension(0:) l )
private

Definition at line 2200 of file dana_aux_par.F.

2201 INTEGER :: N
2202 INTEGER :: K(:), L(0:)
2203 INTEGER :: P, Q, S, T
2204 CONTINUE
2205 l(0) = 1
2206 t = n + 1
2207 DO p = 1,n - 1
2208 IF (k(p) <= k(p+1)) THEN
2209 l(p) = p + 1
2210 ELSE
2211 l(t) = - (p+1)
2212 t = p
2213 END IF
2214 END DO
2215 l(t) = 0
2216 l(n) = 0
2217 IF (l(n+1) == 0) THEN
2218 RETURN
2219 ELSE
2220 l(n+1) = iabs(l(n+1))
2221 END IF
2222 200 CONTINUE
2223 s = 0
2224 t = n+1
2225 p = l(s)
2226 q = l(t)
2227 IF(q .EQ. 0) RETURN
2228 300 CONTINUE
2229 IF(k(p) .GT. k(q)) GOTO 600
2230 CONTINUE
2231 l(s) = sign(p,l(s))
2232 s = p
2233 p = l(p)
2234 IF (p .GT. 0) GOTO 300
2235 CONTINUE
2236 l(s) = q
2237 s = t
2238 DO
2239 t = q
2240 q = l(q)
2241 IF (q .LE. 0) EXIT
2242 END DO
2243 GOTO 800
2244 600 CONTINUE
2245 l(s) = sign(q, l(s))
2246 s = q
2247 q = l(q)
2248 IF (q .GT. 0) GOTO 300
2249 CONTINUE
2250 l(s) = p
2251 s = t
2252 DO
2253 t = p
2254 p = l(p)
2255 IF (p .LE. 0) EXIT
2256 END DO
2257 800 CONTINUE
2258 p = -p
2259 q = -q
2260 IF(q.EQ.0) THEN
2261 l(s) = sign(p, l(s))
2262 l(t) = 0
2263 GOTO 200
2264 END IF
2265 GOTO 300

◆ dmumps_mergeswap()

subroutine dmumps_parallel_analysis::dmumps_mergeswap ( integer n,
integer, dimension(0:) l,
integer, dimension(:) a1,
integer, dimension(:) a2 )
private

Definition at line 2153 of file dana_aux_par.F.

2154 INTEGER :: I, LP, ISWAP, N
2155 INTEGER :: L(0:), A1(:), A2(:)
2156 lp = l(0)
2157 i = 1
2158 DO
2159 IF ((lp==0).OR.(i>n)) EXIT
2160 DO
2161 IF (lp >= i) EXIT
2162 lp = l(lp)
2163 END DO
2164 iswap = a1(lp)
2165 a1(lp) = a1(i)
2166 a1(i) = iswap
2167 iswap = a2(lp)
2168 a2(lp) = a2(i)
2169 a2(i) = iswap
2170 iswap = l(lp)
2171 l(lp) = l(i)
2172 l(i) = lp
2173 lp = iswap
2174 i = i + 1
2175 ENDDO

◆ dmumps_parsymfact()

subroutine dmumps_parallel_analysis::dmumps_parsymfact ( type(dmumps_struc) id,
type(ord_type) ord,
integer, dimension(:), pointer gpe,
integer, dimension(:), pointer gnv,
integer, dimension(:), target work )
private

Definition at line 873 of file dana_aux_par.F.

874 IMPLICIT NONE
875 TYPE(DMUMPS_STRUC) :: id
876 TYPE(ORD_TYPE) :: ord
877 INTEGER, POINTER :: GPE(:), GNV(:)
878 INTEGER, TARGET :: WORK(:)
879 TYPE(GRAPH_TYPE) :: top_graph
880 INTEGER(8), POINTER :: IPE(:), IPET(:),
881 & BUF_PE1(:), BUF_PE2(:), TMP1(:)
882 INTEGER, POINTER :: PE(:),
883 & LENG(:), I_HALO_MAP(:)
884 INTEGER, POINTER :: NDENSE(:), LAST(:),
885 & DEGREE(:), W(:), PERM(:),
886 & LISTVAR_SCHUR(:), NEXT(:),
887 & HEAD(:), NV(:), ELEN(:),
888 & LSTVAR(:)
889 INTEGER, POINTER :: MYLIST(:),
890 & LPERM(:),
891 & LIPERM(:),
892 & NVT(:), BUF_NV1(:),
893 & BUF_NV2(:), ROOTPERM(:),
894 & TMP2(:), BWORK(:), NCLIQUES(:)
895 INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES,
896 & TOTNCLIQUES
897 INTEGER(8) :: MYNVARS, TOTNVARS
898 INTEGER(8), POINTER :: LVARPT(:)
899 INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID,
900 & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP,
901 & NTVAR, TGSIZE, MAXS, RHANDPE,
902 & RHANDNV, RIDX, PROC, JOB, K
903 INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE
904 INTEGER :: STATUSPE(MPI_STATUS_SIZE)
905 INTEGER :: STATUSNV(MPI_STATUS_SIZE)
906 INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE)
907 INTEGER, PARAMETER :: ITAG=30
908 LOGICAL :: AGG6
909 INTEGER :: THRESH
910 nullify(pe, ipe, leng, i_halo_map, ncliques)
911 nullify(ndense, last, degree, w, perm, listvar_schur,
912 & next, head, nv, elen, lstvar)
913 nullify(mylist, lvarpt,
914 & lperm, liperm, ipet, nvt, buf_pe1, buf_pe2,
915 & buf_nv1, buf_nv2, rootperm, tmp1, tmp2, bwork)
916 CALL mpi_comm_rank (id%COMM, myid, ierr)
917 CALL mpi_comm_size (id%COMM, nprocs, ierr)
918 IF(size(work) .LT. 4*id%N) THEN
919 WRITE(lp,*)'Insufficient workspace in DMUMPS_PARSYMFACT'
920 CALL mumps_abort()
921 ELSE
922 head => work( 1 : id%N)
923 elen => work( id%N+1 : 2*id%N)
924 leng => work(2*id%N+1 : 3*id%N)
925 perm => work(3*id%N+1 : 4*id%N)
926 END IF
927 CALL dmumps_get_subtrees(ord, id)
928 CALL mumps_idealloc(ord%SON, ord%BROTHER, ord%NW,
929 & ord%RANGTAB, memcnt=memcnt)
930 nrows_loc = ord%LAST(myid+1)-ord%FIRST(myid+1)+1
931 nrl = nrows_loc
932 toprows = ord%TOPNODES(2)
933 bwork => work(1 : 2*id%N)
934 CALL dmumps_build_loc_graph(id, ord, hidx, ipe, pe, leng,
935 & i_halo_map, top_graph, bwork)
936 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
937 & id%COMM, id%MYID )
938 IF(id%INFO(1).lt.0) RETURN
939 tmp = id%N
940 DO i=1, nprocs
941 tmp = tmp-(ord%LAST(i)-ord%FIRST(i)+1)
942 END DO
943 tmp = ceiling(dble(tmp)*1.10d0)
944 IF(myid .EQ. 0) THEN
945 tmp = max(max(tmp, hidx),1)
946 ELSE
947 tmp = max(hidx,1)
948 END IF
949 size_schur = hidx - nrows_loc
950 CALL mumps_realloc(ndense, tmp, id%INFO, lp,
951 & memcnt=memcnt, errcode=-7)
952 CALL mumps_realloc(last, tmp, id%INFO, lp,
953 & memcnt=memcnt, errcode=-7)
954 CALL mumps_realloc(next, tmp, id%INFO, lp,
955 & memcnt=memcnt, errcode=-7)
956 CALL mumps_realloc(degree, tmp, id%INFO, lp,
957 & memcnt=memcnt, errcode=-7)
958 CALL mumps_realloc(w, tmp, id%INFO, lp,
959 & memcnt=memcnt, errcode=-7)
960 CALL mumps_realloc(nv, tmp, id%INFO, lp,
961 & memcnt=memcnt, errcode=-7)
962 CALL mumps_realloc(listvar_schur, max(size_schur,1), id%INFO, lp,
963 & memcnt=memcnt, errcode=-7)
964 IF(memcnt .GT. maxmem) maxmem=memcnt
965 DO i=1, size_schur
966 listvar_schur(i) = nrows_loc+i
967 END DO
968 thresh = -1
969 agg6 = .false.
970 pfrees = ipe(nrows_loc+1)
971 pfs_save = pfrees
972 pelen = pfrees-1 + 2_8*int(nrows_loc+ord%TOPNODES(2),8)
973 DO i=1, hidx
974 perm(i) = i
975 END DO
976 IF(size_schur.EQ.0) THEN
977 job = 0
978 ELSE
979 job = 1
980 END IF
981 IF(hidx .GT.0) CALL mumps_symqamd_new(job, thresh, ndense(1),
982 & hidx, pelen, ipe(1), pfrees, leng(1), pe(1), nv(1),
983 & elen(1), last(1), ncmpa, degree(1), head(1), next(1),
984 & w(1), perm(1), listvar_schur(1), size_schur, agg6)
985 myncliques = 0
986 mynvars = 0
987 mymaxvars = 0
988 DO i=1, hidx
989 IF(ipe(i) .GT. 0) THEN
990 mymaxvars = max(mymaxvars,leng(i))
991 mynvars = mynvars+leng(i)
992 myncliques = myncliques+1
993 END IF
994 END DO
995 CALL mpi_reduce(mynvars, totnvars, 1, mpi_integer8,
996 & mpi_sum, 0, id%COMM, ierr)
997 CALL mumps_realloc(ncliques, nprocs, id%INFO,
998 & lp, string='NCLIQUES', memcnt=memcnt, errcode=-7)
999 CALL mpi_gather(myncliques, 1, mpi_integer, ncliques(1), 1,
1000 & mpi_integer, 0, id%COMM, ierr)
1001 IF(id%MYID.EQ.0) THEN
1002 totncliques = sum(ncliques)
1003 CALL mumps_i8realloc(lvarpt, totncliques+1, id%INFO,
1004 & lp, string='LVARPT', memcnt=memcnt, errcode=-7)
1005 CALL mumps_irealloc8(lstvar, totnvars, id%INFO,
1006 & lp, string='LSTVAR', memcnt=memcnt, errcode=-7)
1007 lvarpt(1) = 1_8
1008 icliques = 0
1009 DO i=1, hidx
1010 IF(ipe(i) .GT. 0) THEN
1011 icliques = icliques+1
1012 lvarpt(icliques+1) = lvarpt(icliques)+leng(i)
1013 DO j=0, leng(i)-1
1014 lstvar(lvarpt(icliques)+j) =
1015 & i_halo_map(pe(ipe(i)+j)-nrows_loc)
1016 END DO
1017 END IF
1018 END DO
1019 DO proc=1, nprocs-1
1020 DO i=1, ncliques(proc+1)
1021 icliques = icliques+1
1022 CALL mpi_recv(k, 1, mpi_integer, proc, itag, id%COMM,
1023 & statuscliques, ierr)
1024 lvarpt(icliques+1) = lvarpt(icliques)+k
1025 CALL mpi_recv(lstvar(lvarpt(icliques)), k, mpi_integer,
1026 & proc, itag, id%COMM, statuscliques, ierr)
1027 END DO
1028 END DO
1029 lperm => work(3*id%N+1 : 4*id%N)
1030 ntvar = ord%TOPNODES(2)
1031 CALL dmumps_make_loc_idx(id, ord%TOPNODES, lperm, liperm, ord)
1032 CALL dmumps_assemble_top_graph(id, ord%TOPNODES(2), lperm,
1033 & top_graph, totncliques, lstvar, lvarpt, ipet, pe,
1034 & leng, elen)
1035 tgsize = ord%TOPNODES(2)+totncliques
1036 pfreet = ipet(tgsize+1)
1037 pft_save = pfreet
1038 nullify(lperm)
1039 ELSE
1040 CALL mumps_realloc(mylist, mymaxvars, id%INFO,
1041 & lp, string='MYLIST', memcnt=memcnt, errcode=-7)
1042 IF(memcnt .GT. maxmem) maxmem=memcnt
1043 DO i=1, hidx
1044 IF(ipe(i) .GT. 0) THEN
1045 DO j=1, leng(i)
1046 mylist(j) = i_halo_map(pe(ipe(i)+j-1)-nrows_loc)
1047 END DO
1048 CALL mpi_send(leng(i), 1, mpi_integer, 0, itag,
1049 & id%COMM, ierr)
1050 CALL mpi_send(mylist(1), leng(i), mpi_integer, 0, itag,
1051 & id%COMM, ierr)
1052 END IF
1053 END DO
1054 END IF
1055 CALL mumps_idealloc(top_graph%IRN_LOC,
1056 & top_graph%JCN_LOC, ord%TOPNODES, memcnt=memcnt)
1057 IF(myid .EQ. 0) THEN
1058 CALL mumps_irealloc8(pe, max(pfreet+int(tgsize,8),1_8),id%INFO,
1059 & lp, copy=.true., string='J2:PE', memcnt=memcnt,
1060 & errcode=-7)
1061 CALL mumps_realloc(ndense, max(tgsize,1), id%INFO, lp,
1062 & string='J2:NDENSE', memcnt=memcnt, errcode=-7)
1063 CALL mumps_realloc(nvt, max(tgsize,1), id%INFO, lp,
1064 & string='J2:NVT', memcnt=memcnt, errcode=-7)
1065 CALL mumps_realloc(last, max(tgsize,1), id%INFO, lp,
1066 & string='J2:LAST', memcnt=memcnt, errcode=-7)
1067 CALL mumps_realloc(degree, max(tgsize,1), id%INFO, lp,
1068 & string='J2:DEGREE', memcnt=memcnt, errcode=-7)
1069 CALL mumps_realloc(next, max(tgsize,1), id%INFO, lp,
1070 & string='J2:NEXT', memcnt=memcnt, errcode=-7)
1071 CALL mumps_realloc(w, max(tgsize,1), id%INFO, lp,
1072 & string='J2:W', memcnt=memcnt, errcode=-7)
1073 CALL mumps_realloc(listvar_schur, max(totncliques,1), id%INFO,
1074 & lp, string='J2:LVSCH', memcnt=memcnt, errcode=-7)
1075 IF(memcnt .GT. maxmem) maxmem=memcnt
1076 DO i=1, totncliques
1077 listvar_schur(i) = ntvar+i
1078 END DO
1079 thresh = -1
1080 CALL mumps_realloc(head, max(tgsize,1), id%INFO,
1081 & lp, string='J2:HEAD', memcnt=memcnt, errcode=-7)
1082 CALL mumps_realloc(perm, max(tgsize,1), id%INFO,
1083 & lp, copy=.true., string='J2:PERM',
1084 & memcnt=memcnt, errcode=-7)
1085 IF(memcnt .GT. maxmem) maxmem=memcnt
1086 DO i=1, tgsize
1087 perm(i) = i
1088 END DO
1089 pelen = max(pfreet+int(tgsize,8),1_8)
1090 IF(tgsize.GT.0) CALL mumps_symqamd_new(2, -1, ndense(1),
1091 & tgsize, pelen, ipet(1), pfreet, leng(1), pe(1),
1092 & nvt(1), elen(1), last(1), ncmpa, degree(1), head(1),
1093 & next(1), w(1), perm(1), listvar_schur(1), totncliques,
1094 & agg6)
1095 END IF
1096 CALL mpi_barrier(id%COMM, ierr)
1097 CALL mpi_barrier(id%COMM, ierr)
1098 CALL mumps_dealloc(listvar_schur, memcnt=memcnt)
1099 CALL mumps_dealloc(pe, memcnt=memcnt)
1100 IF(myid .EQ. 0) THEN
1101 maxs = nrows_loc
1102 DO i=2, nprocs
1103 IF((ord%LAST(i)-ord%FIRST(i)+1) .GT. maxs)
1104 & maxs = (ord%LAST(i)-ord%FIRST(i)+1)
1105 END DO
1106 CALL mumps_i8realloc(buf_pe1, max(maxs,1), id%INFO,
1107 & lp, string='BUF_PE1', memcnt=memcnt, errcode=-7)
1108 CALL mumps_i8realloc(buf_pe2, max(maxs,1), id%INFO,
1109 & lp, string='BUF_PE2', memcnt=memcnt, errcode=-7)
1110 CALL mumps_realloc(buf_nv1, max(maxs,1), id%INFO,
1111 & lp, string='BUF_NV1', memcnt=memcnt, errcode=-7)
1112 CALL mumps_realloc(buf_nv2, max(maxs,1), id%INFO,
1113 & lp, string='BUF_NV2', memcnt=memcnt, errcode=-7)
1114 CALL mumps_realloc(gpe, id%N, id%INFO,
1115 & lp, string='GPE', memcnt=memcnt, errcode=-7)
1116 CALL mumps_realloc(gnv, id%N, id%INFO,
1117 & lp, string='GNV', memcnt=memcnt, errcode=-7)
1118 CALL mumps_realloc(rootperm, totncliques, id%INFO,
1119 & lp, string='ROOTPERM', memcnt=memcnt, errcode=-7)
1120 IF(memcnt .GT. maxmem) maxmem=memcnt
1121 ridx = 0
1122 tmp1 => buf_pe1
1123 tmp2 => buf_nv1
1124 NULLIFY(buf_pe1, buf_nv1)
1125 buf_pe1 => ipe
1126 buf_nv1 => nv
1127 DO proc=0, nprocs-2
1128 CALL mpi_irecv(buf_pe2(1), ord%LAST(proc+2)-
1129 & ord%FIRST(proc+2)+1, mpi_integer8, proc+1, proc+1,
1130 & id%COMM, rhandpe, ierr)
1131 CALL mpi_irecv(buf_nv2(1), ord%LAST(proc+2)-
1132 & ord%FIRST(proc+2)+1, mpi_integer, proc+1, proc+1,
1133 & id%COMM, rhandnv, ierr)
1134 DO i=1, ord%LAST(proc+1)-ord%FIRST(proc+1)+1
1135 glob_idx = ord%PERITAB(i+ord%FIRST(proc+1)-1)
1136 IF(buf_pe1(i) .GT. 0) THEN
1137 ridx=ridx+1
1138 rootperm(ridx) = glob_idx
1139 gnv(glob_idx) = buf_nv1(i)
1140 ELSE IF (buf_pe1(i) .EQ. 0) THEN
1141 gpe(glob_idx) = 0
1142 gnv(glob_idx) = buf_nv1(i)
1143 ELSE
1144 gpe(glob_idx) = -ord%PERITAB(-buf_pe1(i)+
1145 & ord%FIRST(proc+1)-1)
1146 gnv(glob_idx) = buf_nv1(i)
1147 END IF
1148 END DO
1149 CALL mpi_wait(rhandpe, statuspe, ierr)
1150 CALL mpi_wait(rhandnv, statusnv, ierr)
1151 IF(proc .NE. 0) THEN
1152 tmp1 => buf_pe1
1153 tmp2 => buf_nv1
1154 END IF
1155 buf_pe1 => buf_pe2
1156 buf_nv1 => buf_nv2
1157 NULLIFY(buf_pe2, buf_nv2)
1158 buf_pe2 => tmp1
1159 buf_nv2 => tmp2
1160 NULLIFY(tmp1, tmp2)
1161 END DO
1162 DO i=1, ord%LAST(proc+1)-ord%FIRST(proc+1)+1
1163 glob_idx = ord%PERITAB(i+ord%FIRST(proc+1)-1)
1164 IF(buf_pe1(i) .GT. 0) THEN
1165 ridx=ridx+1
1166 rootperm(ridx) = glob_idx
1167 gnv(glob_idx) = buf_nv1(i)
1168 ELSE IF (buf_pe1(i) .EQ. 0) THEN
1169 gpe(glob_idx) = 0
1170 gnv(glob_idx) = buf_nv1(i)
1171 ELSE
1172 gpe(glob_idx) = -ord%PERITAB(-buf_pe1(i)+
1173 & ord%FIRST(proc+1)-1)
1174 gnv(glob_idx) = buf_nv1(i)
1175 END IF
1176 END DO
1177 DO i=1, ntvar
1178 glob_idx = liperm(i)
1179 IF(ipet(i) .EQ. 0) THEN
1180 gpe(glob_idx) = 0
1181 gnv(glob_idx) = nvt(i)
1182 ELSE
1183 gpe(glob_idx) = -liperm(-ipet(i))
1184 gnv(glob_idx) = nvt(i)
1185 END IF
1186 END DO
1187 DO i=1, totncliques
1188 glob_idx = rootperm(i)
1189 gpe(glob_idx) = -liperm(-ipet(ntvar+i))
1190 END DO
1191 ELSE
1192 CALL mpi_send(ipe(1), ord%LAST(myid+1)-ord%FIRST(myid+1)+1,
1193 & mpi_integer8, 0, myid, id%COMM, ierr)
1194 CALL mpi_send(nv(1), ord%LAST(myid+1)-ord%FIRST(myid+1)+1,
1195 & mpi_integer, 0, myid, id%COMM, ierr)
1196 END IF
1197 CALL mumps_dealloc(buf_nv1, buf_nv2, memcnt=memcnt)
1198 CALL mumps_i8dealloc(buf_pe1, buf_pe2, ipe, ipet,
1199 & tmp1, lvarpt, memcnt=memcnt)
1200 CALL mumps_dealloc(pe, i_halo_map, ndense,
1201 & last, degree, memcnt=memcnt)
1202 CALL mumps_dealloc(w, listvar_schur, next,
1203 & nv, memcnt=memcnt)
1204 CALL mumps_dealloc(lstvar, ncliques, mylist,
1205 & memcnt=memcnt)
1206 CALL mumps_dealloc(lperm, liperm, nvt, memcnt=memcnt)
1207 CALL mumps_dealloc(rootperm, tmp2, memcnt=memcnt)
1208 NULLIFY(head, elen, leng, perm)
1209 RETURN
mumps_symqamd_new
subroutine mumps_symqamd_new(job, thresh, ndense, n, iwlen, pe, pfree, len, iw, nv, elen, last, ncmpa, degree, head, next, w, perm, complem_list, size_complem_list, agg6)
Definition ana_AMDMF.F:20
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_reduce
subroutine mpi_reduce(sendbuf, recvbuf, cnt, datatype, op, root, comm, ierr)
Definition mpi.f:120
mpi_barrier
subroutine mpi_barrier(comm, ierr)
Definition mpi.f:188
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372

◆ dmumps_send_buf()

subroutine dmumps_parallel_analysis::dmumps_send_buf ( type(arrpnt), dimension(:) apnt,
integer proc,
integer nprocs,
integer bufsize,
integer(8), dimension(:) ipe,
integer, dimension(:), pointer pe,
integer, dimension(:), pointer leng,
integer, dimension(:), pointer rcvbuf,
integer(8), dimension(:) msgcnt,
integer, dimension(:) sndcnt,
integer comm )
private

Definition at line 1907 of file dana_aux_par.F.

1909 IMPLICIT NONE
1910 INTEGER :: NPROCS, PROC, COMM, allocok
1911 TYPE(ARRPNT) :: APNT(:)
1912 INTEGER :: BUFSIZE
1913 INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:)
1914 INTEGER :: SNDCNT(:)
1915 INTEGER(8) :: MSGCNT(:), IPE(:)
1916 LOGICAL, SAVE :: INIT = .true.
1917 INTEGER, POINTER, SAVE :: SPACE(:,:,:)
1918 LOGICAL, POINTER, SAVE :: PENDING(:)
1919 INTEGER, POINTER, SAVE :: REQ(:), CPNT(:)
1920 INTEGER :: IERR, MYID, I, SOURCE
1921 INTEGER(8) :: TOTMSG
1922 LOGICAL :: FLAG, TFLAG
1923 INTEGER :: STATUS(MPI_STATUS_SIZE)
1924 INTEGER :: TSTATUS(MPI_STATUS_SIZE)
1925 INTEGER, PARAMETER :: ITAG=30, ftag=31
1926 INTEGER, POINTER :: TMPI(:), RCVCNT(:)
1927 CALL mpi_comm_rank (comm, myid, ierr)
1928 CALL mpi_comm_size (comm, nprocs, ierr)
1929 IF(init) THEN
1930 ALLOCATE(space(2*bufsize, 2, nprocs), stat=allocok)
1931 IF(allocok.GT.0) THEN
1932 write(*,*) "Allocation error of SPACE in DMUMPS_SEND_BUF"
1933 return
1934 ENDIF
1935 ALLOCATE(rcvbuf(2*bufsize), stat=allocok)
1936 IF(allocok.GT.0) THEN
1937 write(*,*) "Allocation error of RCVBUF in DMUMPS_SEND_BUF"
1938 return
1939 ENDIF
1940 ALLOCATE(pending(nprocs), cpnt(nprocs), stat=allocok)
1941 IF(allocok.GT.0) THEN
1942 write(*,*) "Allocation error of PENDING/CPNT"
1943 & ," in DMUMPS_SEND_BUF"
1944 return
1945 ENDIF
1946 ALLOCATE(req(nprocs), stat=allocok)
1947 IF(allocok.GT.0) THEN
1948 write(*,*) "Allocation error of REQ in DMUMPS_SEND_BUF"
1949 return
1950 ENDIF
1951 pending = .false.
1952 DO i=1, nprocs
1953 apnt(i)%BUF => space(:,1,i)
1954 cpnt(i) = 1
1955 END DO
1956 init = .false.
1957 RETURN
1958 END IF
1959 IF(proc .EQ. -1) THEN
1960 totmsg = sum(msgcnt)
1961 DO
1962 IF(totmsg .EQ. 0) EXIT
1963 CALL mpi_recv(rcvbuf(1), 2*bufsize, mpi_integer,
1964 & mpi_any_source, itag, comm, status, ierr)
1965 CALL dmumps_assemble_msg(bufsize, rcvbuf, ipe, pe, leng)
1966 source = status(mpi_source)
1967 totmsg = totmsg-1
1968 msgcnt(source+1)=msgcnt(source+1)-1
1969 END DO
1970 DO i=1, nprocs
1971 IF(pending(i)) THEN
1972 CALL mpi_wait(req(i), tstatus, ierr)
1973 END IF
1974 END DO
1975 ALLOCATE(rcvcnt(nprocs), stat=allocok)
1976 IF(allocok.GT.0) THEN
1977 write(*,*) "Allocation error of RCVCNT in DMUMPS_SEND_BUF"
1978 return
1979 ENDIF
1980 CALL mpi_alltoall(sndcnt(1), 1, mpi_integer, rcvcnt(1), 1,
1981 & mpi_integer, comm, ierr)
1982 DO i=1, nprocs
1983 IF(sndcnt(i) .GT. 0) THEN
1984 tmpi => apnt(i)%BUF(:)
1985 CALL mpi_isend(tmpi(1), 2*sndcnt(i), mpi_integer, i-1,
1986 & ftag, comm, req(i), ierr)
1987 END IF
1988 END DO
1989 DO i=1, nprocs
1990 IF(rcvcnt(i) .GT. 0) THEN
1991 CALL mpi_recv(rcvbuf(1), 2*rcvcnt(i), mpi_integer, i-1,
1992 & ftag, comm, status, ierr)
1993 CALL dmumps_assemble_msg(rcvcnt(i), rcvbuf,
1994 & ipe, pe, leng)
1995 END IF
1996 END DO
1997 DO i=1, nprocs
1998 IF(sndcnt(i) .GT. 0) THEN
1999 CALL mpi_wait(req(i), tstatus, ierr)
2000 END IF
2001 END DO
2002 DEALLOCATE(space)
2003 DEALLOCATE(pending, cpnt)
2004 DEALLOCATE(req)
2005 DEALLOCATE(rcvbuf, rcvcnt)
2006 nullify(space, pending, cpnt, req, rcvbuf, rcvcnt)
2007 init = .true.
2008 RETURN
2009 END IF
2010 IF(pending(proc)) THEN
2011 DO
2012 CALL mpi_test(req(proc), tflag, tstatus, ierr)
2013 IF(tflag) THEN
2014 pending(proc) = .false.
2015 EXIT
2016 ELSE
2017 CALL mpi_iprobe( mpi_any_source, itag, comm,
2018 & flag, status, ierr )
2019 IF(flag) THEN
2020 source = status(mpi_source)
2021 CALL mpi_recv(rcvbuf(1), 2*bufsize, mpi_integer,
2022 & source, itag, comm, status, ierr)
2023 CALL dmumps_assemble_msg(bufsize, rcvbuf, ipe,
2024 & pe, leng)
2025 msgcnt(source+1)=msgcnt(source+1)-1
2026 END IF
2027 END IF
2028 END DO
2029 END IF
2030 tmpi => apnt(proc)%BUF(:)
2031 CALL mpi_isend(tmpi(1), 2*bufsize, mpi_integer, proc-1,
2032 & itag, comm, req(proc), ierr)
2033 pending(proc) = .true.
2034 cpnt(proc) = mod(cpnt(proc),2)+1
2035 apnt(proc)%BUF => space(:,cpnt(proc),proc)
2036 sndcnt(proc) = 0
2037 RETURN
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_test
subroutine mpi_test(ireq, flag, status, ierr)
Definition mpi.f:502

◆ dmumps_set_par_ord()

subroutine dmumps_parallel_analysis::dmumps_set_par_ord ( type(dmumps_struc) id,
type(ord_type) ord )
private

Definition at line 213 of file dana_aux_par.F.

214 TYPE(DMUMPS_STRUC) :: id
215 TYPE(ORD_TYPE) :: ord
216 INTEGER :: IERR
217#if defined(parmetis) || defined(parmetis3)
218 INTEGER :: I, COLOR, BASE, WORKERS
219 LOGICAL :: IDO
220#endif
221 IF(id%MYID .EQ. 0) id%KEEP(245) = id%ICNTL(29)
222 CALL mpi_bcast( id%KEEP(245), 1,
223 & mpi_integer, 0, id%COMM, ierr )
224 IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN
225 id%KEEP(245) = 0
226 END IF
227 IF (id%KEEP(245) .EQ. 0) THEN
228#if defined(ptscotch)
229 IF(id%NSLAVES .LT. 2) THEN
230 IF(prokg) WRITE(mpg,'("Warning: older versions
231 &of PT-SCOTCH require at least 2 processors.")')
232 END IF
233 ord%ORDTOOL = 1
234 ord%TOPSTRAT = 0
235 ord%SUBSTRAT = 0
236 ord%COMM = id%COMM
237 ord%COMM_NODES = id%COMM_NODES
238 ord%NPROCS = id%NPROCS
239 ord%NSLAVES = id%NSLAVES
240 ord%MYID = id%MYID
241 ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1)
242 id%KEEP(245) = 1
243 IF(prokg) WRITE(mpg,
244 & '("Parallel ordering tool set to PT-SCOTCH.")')
245 RETURN
246#endif
247#if defined(parmetis) || defined(parmetis3)
248 IF(id%N.LE.100) THEN
249 workers = 2
250 ELSE
251 workers = min(id%NSLAVES,id%N/16)
252 END IF
253 i=1
254 DO
255 IF (i .GT. workers) EXIT
256 ord%NSLAVES = i
257 i = i*2
258 END DO
259 base = id%NPROCS-id%NSLAVES
260 ord%NPROCS = ord%NSLAVES + base
261 ido = (id%MYID .GE. base) .AND.
262 & (id%MYID .LE. base+ord%NSLAVES-1)
263 ord%IDO = ido
264 IF ( ido ) THEN
265 color = 1
266 ELSE
267 color = mpi_undefined
268 END IF
269 CALL mpi_comm_split( id%COMM, color, 0,
270 & ord%COMM_NODES, ierr )
271 ord%ORDTOOL = 2
272 ord%TOPSTRAT = 0
273 ord%SUBSTRAT = 0
274 ord%MYID = id%MYID
275 IF(prokg) WRITE(mpg,
276 & '("Parallel ordering tool set to ParMETIS.")')
277 id%KEEP(245) = 2
278 RETURN
279#endif
280 id%INFO(1) = -38
281 id%INFOG(1) = -38
282 IF(id%MYID .EQ.0 ) THEN
283 WRITE(lp,
284 & '("No parallel ordering tools available.")')
285 WRITE(lp,
286 & '("Please install PT-SCOTCH or ParMETIS.")')
287 END IF
288 RETURN
289 ELSE IF (id%KEEP(245) .EQ. 1) THEN
290#if defined(ptscotch)
291 IF(id%NSLAVES .LT. 2) THEN
292 IF(prokg) WRITE(mpg,'("Warning: older versions
293 &of PT-SCOTCH require at least 2 processors.")')
294 END IF
295 ord%ORDTOOL = 1
296 ord%TOPSTRAT = 0
297 ord%SUBSTRAT = 0
298 ord%COMM = id%COMM
299 ord%COMM_NODES = id%COMM_NODES
300 ord%NPROCS = id%NPROCS
301 ord%NSLAVES = id%NSLAVES
302 ord%MYID = id%MYID
303 ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1)
304 IF(prokg) WRITE(mpg,
305 & '(" Using PT-SCOTCH for parallel ordering")')
306 RETURN
307#else
308 id%INFOG(1) = -38
309 id%INFO(1) = -38
310 IF(id%MYID .EQ.0 ) WRITE(lp,
311 & '(" PT-SCOTCH not available")')
312 RETURN
313#endif
314 ELSE IF (id%KEEP(245) .EQ. 2) THEN
315#if defined(parmetis) || defined(parmetis3)
316 IF(id%N.LE.100) THEN
317 workers = 2
318 ELSE
319 workers = min(id%NSLAVES,id%N/16)
320 END IF
321 i=1
322 DO
323 IF (i .GT. workers) EXIT
324 ord%NSLAVES = i
325 i = i*2
326 END DO
327 base = id%NPROCS-id%NSLAVES
328 ord%NPROCS = ord%NSLAVES + base
329 ido = (id%MYID .GE. base) .AND.
330 & (id%MYID .LE. base+ord%NSLAVES-1)
331 ord%IDO = ido
332 IF ( ido ) THEN
333 color = 1
334 ELSE
335 color = mpi_undefined
336 END IF
337 CALL mpi_comm_split( id%COMM, color, 0, ord%COMM_NODES,
338 & ierr )
339 ord%ORDTOOL = 2
340 ord%TOPSTRAT = 0
341 ord%SUBSTRAT = 0
342 ord%MYID = id%MYID
343 IF(prokg) WRITE(mpg,
344 & '(" Using ParMETIS for parallel ordering")')
345 RETURN
346#else
347 id%INFOG(1) = -38
348 id%INFO(1) = -38
349 IF(id%MYID .EQ.0 ) WRITE(lp,
350 & '(" ParMETIS not available.")')
351 RETURN
352#endif
353 END IF
mpi_comm_split
subroutine mpi_comm_split(comm, color, key, comm2, ierr)
Definition mpi.f:272
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205

◆ dmumps_stop_descent()

logical function dmumps_parallel_analysis::dmumps_stop_descent ( type(dmumps_struc) id,
type(ord_type) ord,
integer nactive,
integer anode,
integer rproc,
integer, dimension(nnodes) alist,
integer, dimension(nnodes) list,
integer peakmem,
integer nnodes,
logical, optional checkmem )
private

Definition at line 633 of file dana_aux_par.F.

635 IMPLICIT NONE
636 LOGICAL :: DMUMPS_STOP_DESCENT
637 INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES
638 INTEGER :: ALIST(NNODES), LIST(NNODES)
639 TYPE(ORD_TYPE) :: ord
640 TYPE(DMUMPS_STRUC) :: id
641 LOGICAL, OPTIONAL :: CHECKMEM
642 INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS
643 INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM
644 INTEGER :: I, NZ_ROW, WEIGHT
645 LOGICAL :: ICHECKMEM
646 INTEGER :: NZ4
647 IF(present(checkmem)) THEN
648 icheckmem = checkmem
649 ELSE
650 icheckmem = .false.
651 END IF
652 dmumps_stop_descent = .false.
653 IF(nactive .GE. rproc) THEN
654 dmumps_stop_descent = .true.
655 RETURN
656 END IF
657 IF(nactive .EQ. 0) THEN
658 dmumps_stop_descent = .true.
659 RETURN
660 END IF
661 IF(.NOT. icheckmem) RETURN
662 big = alist(nactive)
663 IF(nactive .GT. 1) THEN
664 max_nrows = ord%NW(alist(nactive-1))
665 min_nrows = ord%NW(alist(1))
666 ELSE
667 max_nrows = 0
668 min_nrows = id%N
669 END IF
670 DO i=1, anode
671 weight = ord%NW(list(i))
672 IF(weight .GT. max_nrows) max_nrows = weight
673 IF(weight .LT. min_nrows) min_nrows = weight
674 END DO
675 i = ord%SON(big)
676 DO
677 weight = ord%NW(i)
678 IF(weight .GT. max_nrows) max_nrows = weight
679 IF(weight .LT. min_nrows) min_nrows = weight
680 IF(ord%BROTHER(i) .EQ. -1) EXIT
681 i = ord%BROTHER(i)
682 END DO
683 toprows = ord%TOPNODES(2)+ord%RANGTAB(big+1)-ord%RANGTAB(big)
684 submem = 7 *id%N
685 hostmem = 12*id%N
686 nz4=int(id%KEEP8(28))
687 nz_row = 2*(nz4/id%N)
688 IF(id%KEEP(46) .EQ. 0) THEN
689 nrl = 0
690 ELSE
691 nrl = min_nrows
692 END IF
693 hostmem = hostmem + 2*toprows*nz_row
694 hostmem = hostmem +nrl
695 hostmem = hostmem + max(nrl,toprows)*(nz_row+2)
696 hostmem = hostmem + 6*max(nrl,toprows)
697 hostmem = hostmem + 3*toprows
698 nrl = max_nrows
699 submem = submem +nrl
700 submem = submem + nrl*(nz_row+2)
701 submem = submem + 6*nrl
702 ipeakmem = max(hostmem, submem)
703 IF((ipeakmem .GT. peakmem) .AND.
704 & (peakmem .NE. 0)) THEN
705 dmumps_stop_descent = .true.
706 RETURN
707 ELSE
708 dmumps_stop_descent = .false.
709 peakmem = ipeakmem
710 RETURN
711 END IF

◆ mumps_getsize()

integer function dmumps_parallel_analysis::mumps_getsize ( integer, dimension(:), pointer a)
private

Definition at line 2267 of file dana_aux_par.F.

2268 INTEGER, POINTER :: A(:)
2269 INTEGER :: MUMPS_GETSIZE
2270 IF(associated(a)) THEN
2271 mumps_getsize = size(a)
2272 ELSE
2273 mumps_getsize = 0_8
2274 END IF
2275 RETURN

Variable Documentation

◆ lp

integer dmumps_parallel_analysis::lp
private

Definition at line 49 of file dana_aux_par.F.

◆ lpok

logical dmumps_parallel_analysis::lpok
private

Definition at line 51 of file dana_aux_par.F.

◆ maxmem

integer(8) dmumps_parallel_analysis::maxmem
private

Definition at line 50 of file dana_aux_par.F.

◆ memcnt

integer(8) dmumps_parallel_analysis::memcnt
private

Definition at line 50 of file dana_aux_par.F.

50 INTEGER(8) :: MEMCNT, MAXMEM

◆ mp

integer dmumps_parallel_analysis::mp

Definition at line 49 of file dana_aux_par.F.

49 INTEGER :: MP, MPG, LP, NRL, TOPROWS

◆ mpg

integer dmumps_parallel_analysis::mpg
private

Definition at line 49 of file dana_aux_par.F.

◆ nrl

integer dmumps_parallel_analysis::nrl
private

Definition at line 49 of file dana_aux_par.F.

◆ prok

logical dmumps_parallel_analysis::prok
private

Definition at line 51 of file dana_aux_par.F.

51 LOGICAL :: PROK, PROKG, LPOK

◆ prokg

logical dmumps_parallel_analysis::prokg
private

Definition at line 51 of file dana_aux_par.F.

◆ toprows

integer dmumps_parallel_analysis::toprows
private

Definition at line 49 of file dana_aux_par.F.