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

Go to the source code of this file.

Functions/Subroutines

subroutine zmumps_ass_root (root, keep50, nrow_son, ncol_son, indrow_son, indcol_son, nsupcol, val_son, val_root, local_m, local_n, rhs_root, nloc_root, cbp)
recursive subroutine zmumps_build_and_send_cb_root (comm_load, ass_irecv, n, ison, iroot, ptri, ptrr, root, nbrow, nbcol, shift_list_row_son, shift_list_col_son, shift_val_son_arg, lda_arg, tag, myid, comm, bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la, ptrist, ptlust_s, ptrfac, ptrast, step, pimaster, pamaster, nstk, comp, iflag, ierror, perm, ipool, lpool, leaf, nbfin, slavef, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, transpose_asm, nd, frere, lptrar, nelt, frtptr, frtelt, istep_to_iniv2, tab_pos_in_pere, lrgroups)
subroutine zmumps_set_lda_shift_val_son (iw, liw, ioldps, lda, shift_val_son)
subroutine zmumps_root_local_assembly (n, val_root, local_m, local_n, npcol, nprow, mblock, nblock, nbcol_son, nbrow_son, indcol_son, indrow_son, ld_son, val_son, subset_row, subset_col, nsubset_row, nsubset_col, nsuprow, nsupcol, rg2l_row, rg2l_col, transpose_asm, keep, rhs_root, nloc)
subroutine zmumps_init_root_ana (myid, nprocs, n, root, comm_root, iroot, fils, k50, k46, k51, k60, idnprow, idnpcol, idmblock, idnblock)
subroutine zmumps_init_root_fac (n, root, fils, iroot, keep, info)
subroutine zmumps_def_grid (nprocs, nprow, npcol, size, k50)
subroutine zmumps_scatter_root (myid, m, n, aseq, local_m, local_n, mblock, nblock, apar, master_root, nprow, npcol, comm)
subroutine zmumps_gather_root (myid, m, n, aseq, local_m, local_n, mblock, nblock, apar, master_root, nprow, npcol, comm)
subroutine zmumps_root_alloc_static (root, iroot, n, iw, liw, a, la, fils, dad, myid, slavef, procnode_steps, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, itloc, rhs_mumps, comp, lrlus, iflag, keep, keep8, dkeep, ierror)
subroutine zmumps_asm_elt_root (n, root, valroot, local_m_lld, local_m, local_n, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, keep, keep8, myid)
subroutine zmumps_asm_rhs_root (n, fils, root, keep, rhs_mumps, iflag, ierror)
subroutine zmumps_asm_arr_root (n, root, iroot, valroot, local_m_lld, local_m, local_n, fils, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, myid)

Function/Subroutine Documentation

◆ zmumps_asm_arr_root()

subroutine zmumps_asm_arr_root ( integer n,
type (zmumps_root_struc) root,
integer iroot,
complex(kind=8), dimension(local_m_lld,local_n) valroot,
integer local_m_lld,
integer local_m,
integer local_n,
integer, dimension( n ) fils,
integer(8), dimension( n ), intent(in) ptraiw,
integer(8), dimension( n ), intent(in) ptrarw,
integer, dimension(lintarr) intarr,
complex(kind=8), dimension(ldblarr) dblarr,
integer(8), intent(in) lintarr,
integer(8), intent(in) ldblarr,
integer myid )

Definition at line 1330 of file ztype3_root.F.

1335 USE zmumps_struc_def, ONLY : zmumps_root_struc
1336 IMPLICIT NONE
1337 TYPE (ZMUMPS_ROOT_STRUC) :: root
1338 INTEGER :: N, MYID, IROOT, LOCAL_M, LOCAL_N
1339 INTEGER :: LOCAL_M_LLD
1340 INTEGER FILS( N )
1341 INTEGER(8), INTENT(IN) :: PTRARW( N ), PTRAIW( N )
1342 COMPLEX(kind=8) VALROOT(LOCAL_M_LLD,LOCAL_N)
1343 INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR
1344 INTEGER INTARR(LINTARR)
1345 COMPLEX(kind=8) DBLARR(LDBLARR)
1346 COMPLEX(kind=8) VAL
1347 INTEGER(8) :: JJ, J1,JK, J2,J3, J4, AINPUT
1348 INTEGER IORG, IBROT, NUMORG,
1349 & IROW, JCOL
1350 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID
1351 INTEGER ILOCROOT, JLOCROOT
1352 numorg = root%ROOT_SIZE
1353 ibrot = iroot
1354 DO iorg = 1, numorg
1355 jk = ptraiw(ibrot)
1356 ainput = ptrarw(ibrot)
1357 ibrot = fils(ibrot)
1358 jj = jk + 1
1359 j1 = jj + 1
1360 j2 = j1 + intarr(jk)
1361 j3 = j2 + 1
1362 j4 = j2 - intarr(jj)
1363 jcol = intarr(j1)
1364 DO jj = j1, j2
1365 irow = intarr(jj)
1366 val = dblarr(ainput)
1367 ainput = ainput + 1
1368 iposroot = root%RG2L_ROW( irow )
1369 jposroot = root%RG2L_COL( jcol )
1370 irow_grid = mod( ( iposroot - 1 ) / root%MBLOCK, root%NPROW )
1371 jcol_grid = mod( ( jposroot - 1 ) / root%NBLOCK, root%NPCOL )
1372 IF ( irow_grid .EQ. root%MYROW .AND.
1373 & jcol_grid .EQ. root%MYCOL ) THEN
1374 ilocroot = root%MBLOCK * ( ( iposroot - 1 ) /
1375 & ( root%MBLOCK * root%NPROW ) )
1376 & + mod( iposroot - 1, root%MBLOCK ) + 1
1377 jlocroot = root%NBLOCK * ( ( jposroot - 1 ) /
1378 & ( root%NBLOCK * root%NPCOL ) )
1379 & + mod( jposroot - 1, root%NBLOCK ) + 1
1380 valroot( ilocroot, jlocroot ) =
1381 & valroot( ilocroot, jlocroot ) + val
1382 END IF
1383 END DO
1384 IF (j3 .LE. j4) THEN
1385 irow = intarr(j1)
1386 DO jj= j3,j4
1387 jcol = intarr(jj)
1388 val = dblarr(ainput)
1389 ainput = ainput + 1
1390 iposroot = root%RG2L_ROW( irow )
1391 jposroot = root%RG2L_COL( jcol )
1392 irow_grid= mod( ( iposroot - 1 )/root%MBLOCK, root%NPROW)
1393 jcol_grid= mod( ( jposroot - 1 )/root%NBLOCK, root%NPCOL)
1394 IF ( irow_grid .EQ. root%MYROW .AND.
1395 & jcol_grid .EQ. root%MYCOL ) THEN
1396 ilocroot = root%MBLOCK * ( ( iposroot - 1 ) /
1397 & ( root%MBLOCK * root%NPROW ) )
1398 & + mod( iposroot - 1, root%MBLOCK ) + 1
1399 jlocroot = root%NBLOCK * ( ( jposroot - 1 ) /
1400 & ( root%NBLOCK * root%NPCOL ) )
1401 & + mod( jposroot - 1, root%NBLOCK ) + 1
1402 valroot( ilocroot, jlocroot ) =
1403 & valroot( ilocroot, jlocroot ) + val
1404 END IF
1405 END DO
1406 ENDIF
1407 ENDDO
1408 RETURN
zmumps_struc_def
Definition zmumps_struc_def.F:14

◆ zmumps_asm_elt_root()

subroutine zmumps_asm_elt_root ( integer n,
type (zmumps_root_struc) root,
complex(kind=8), dimension(local_m_lld,local_n) valroot,
integer local_m_lld,
integer local_m,
integer local_n,
integer lptrar,
integer nelt,
integer, dimension( n+1) frtptr,
integer, dimension( nelt ) frtelt,
integer(8), dimension( lptrar ), intent(in) ptraiw,
integer(8), dimension( lptrar ), intent(in) ptrarw,
integer, dimension(lintarr), intent(inout) intarr,
complex(kind=8), dimension(ldblarr) dblarr,
integer(8), intent(in) lintarr,
integer(8), intent(in) ldblarr,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
integer myid )

Definition at line 1215 of file ztype3_root.F.

1222 USE zmumps_struc_def, ONLY : zmumps_root_struc
1223 IMPLICIT NONE
1224 TYPE (ZMUMPS_ROOT_STRUC) :: root
1225 INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500)
1226 INTEGER :: LOCAL_M_LLD
1227 INTEGER(8) KEEP8(150)
1228 COMPLEX(kind=8) VALROOT(LOCAL_M_LLD,LOCAL_N)
1229 INTEGER LPTRAR, NELT
1230 INTEGER FRTPTR( N+1), FRTELT( NELT )
1231 INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
1232 INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR
1233 INTEGER, INTENT(INOUT) :: INTARR(LINTARR)
1234 COMPLEX(kind=8) DBLARR(LDBLARR)
1235 INTEGER(8) :: J1, J2, K8, IPTR
1236 INTEGER :: IELT, I, J, IGLOB, JGLOB, SIZEI, IBEG
1237 INTEGER :: ARROW_ROOT
1238 INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID
1239 INTEGER :: ILOCROOT, JLOCROOT
1240 arrow_root = 0
1241 DO iptr = frtptr(keep(38)), frtptr(keep(38)+1) - 1
1242 ielt = frtelt( iptr )
1243 j1 = ptraiw(ielt)
1244 j2 = ptraiw(ielt+1)-1
1245 k8 = ptrarw(ielt)
1246 sizei=int(j2-j1)+1
1247 DO j=1, sizei
1248 jglob = intarr(j1+j-1)
1249 intarr(j1+j-1) = root%RG2L_ROW(jglob)
1250 ENDDO
1251 DO j = 1, sizei
1252 jglob = intarr(j1+j-1)
1253 IF ( keep(50).eq. 0 ) THEN
1254 ibeg = 1
1255 ELSE
1256 ibeg = j
1257 END IF
1258 DO i = ibeg, sizei
1259 iglob = intarr(j1+i-1)
1260 IF ( keep(50).eq.0 ) THEN
1261 iposroot = intarr(j1+i-1)
1262 jposroot = intarr(j1+j-1)
1263 ELSE
1264 IF ( intarr(j1+i-1).GT. intarr(j1+j-1) ) THEN
1265 iposroot = intarr(j1+i-1)
1266 jposroot = intarr(j1+j-1)
1267 ELSE
1268 iposroot = intarr(j1+j-1)
1269 jposroot = intarr(j1+i-1)
1270 END IF
1271 END IF
1272 irow_grid = mod( ( iposroot - 1 )/root%MBLOCK,
1273 & root%NPROW )
1274 jcol_grid = mod( ( jposroot - 1 )/root%NBLOCK,
1275 & root%NPCOL )
1276 IF ( irow_grid.EQ.root%MYROW .AND.
1277 & jcol_grid.EQ.root%MYCOL ) THEN
1278 ilocroot = root%MBLOCK * ( ( iposroot - 1 ) /
1279 & ( root%MBLOCK * root%NPROW ) )
1280 & + mod( iposroot - 1, root%MBLOCK ) + 1
1281 jlocroot = root%NBLOCK * ( ( jposroot - 1 ) /
1282 & ( root%NBLOCK * root%NPCOL ) )
1283 & + mod( jposroot - 1, root%NBLOCK ) + 1
1284 valroot( ilocroot, jlocroot ) =
1285 & valroot( ilocroot, jlocroot ) + dblarr(k8)
1286 ENDIF
1287 k8 = k8 + 1_8
1288 END DO
1289 END DO
1290 arrow_root = arrow_root + int(ptrarw(ielt+1_8)-ptrarw(ielt))
1291 END DO
1292 keep(49) = arrow_root
1293 RETURN

◆ zmumps_asm_rhs_root()

subroutine zmumps_asm_rhs_root ( integer n,
integer, dimension(n) fils,
type (zmumps_root_struc ) root,
integer, dimension(500) keep,
complex(kind=8), dimension(keep(255)) rhs_mumps,
integer iflag,
integer ierror )

Definition at line 1295 of file ztype3_root.F.

1298 USE zmumps_struc_def, ONLY : zmumps_root_struc
1299 IMPLICIT NONE
1300 INTEGER N, KEEP(500), IFLAG, IERROR
1301 INTEGER FILS(N)
1302 TYPE (ZMUMPS_ROOT_STRUC ) :: root
1303 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
1304 INTEGER JCOL, IPOS_ROOT, JPOS_ROOT,
1305 & IROW_GRID, JCOL_GRID, ILOCRHS, JLOCRHS,
1306 & INODE
1307 inode = keep(38)
1308 DO WHILE (inode.GT.0)
1309 ipos_root = root%RG2L_ROW( inode )
1310 irow_grid = mod( ( ipos_root - 1 ) / root%MBLOCK, root%NPROW )
1311 IF ( irow_grid .NE. root%MYROW ) GOTO 100
1312 ilocrhs = root%MBLOCK * ( ( ipos_root - 1 ) /
1313 & ( root%MBLOCK * root%NPROW ) )
1314 & + mod( ipos_root - 1, root%MBLOCK ) + 1
1315 DO jcol = 1, keep(253)
1316 jpos_root = jcol
1317 jcol_grid = mod((jpos_root-1)/root%NBLOCK, root%NPCOL)
1318 IF (jcol_grid.NE.root%MYCOL ) cycle
1319 jlocrhs = root%NBLOCK * ( ( jpos_root - 1 ) /
1320 & ( root%NBLOCK * root%NPCOL ) )
1321 & + mod( jpos_root - 1, root%NBLOCK ) + 1
1322 root%RHS_ROOT(ilocrhs, jlocrhs) =
1323 & rhs_mumps(inode+(jcol-1)*keep(254))
1324 ENDDO
1325 100 CONTINUE
1326 inode=fils(inode)
1327 ENDDO
1328 RETURN

◆ zmumps_ass_root()

subroutine zmumps_ass_root ( type (zmumps_root_struc) root,
integer, intent(in) keep50,
integer nrow_son,
integer ncol_son,
integer, dimension( nrow_son ) indrow_son,
integer, dimension( ncol_son ) indcol_son,
integer nsupcol,
complex(kind=8), dimension( ncol_son, nrow_son ) val_son,
complex(kind=8), dimension( local_m, local_n ) val_root,
integer local_m,
integer local_n,
complex(kind=8), dimension( local_m, nloc_root ) rhs_root,
integer nloc_root,
integer, intent(in) cbp )

Definition at line 14 of file ztype3_root.F.

19 USE zmumps_struc_def, ONLY : zmumps_root_struc
20 IMPLICIT NONE
21 TYPE (ZMUMPS_ROOT_STRUC) :: root
22 INTEGER, INTENT(IN) :: KEEP50
23 INTEGER NCOL_SON, NROW_SON, NSUPCOL
24 INTEGER, intent(in) :: CBP
25 INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON )
26 INTEGER LOCAL_M, LOCAL_N
27 COMPLEX(kind=8) VAL_SON( NCOL_SON, NROW_SON )
28 COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N )
29 INTEGER NLOC_ROOT
30 COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC_ROOT )
31 INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT
32 IF (cbp .EQ. 0) THEN
33 DO i = 1, nrow_son
34 indrow = indrow_son(i)
35 iposroot = (root%NPROW*((indrow-1)/root%MBLOCK)+root%MYROW)
36 & * root%MBLOCK + mod(indrow-1,root%MBLOCK) + 1
37 DO j = 1, ncol_son-nsupcol
38 indcol = indcol_son(j)
39 IF (keep50.NE.0) THEN
40 jposroot = (root%NPCOL*((indcol-1)/root%NBLOCK)+root%MYCOL)
41 & * root%NBLOCK + mod(indcol-1,root%NBLOCK) + 1
42 IF (iposroot < jposroot) THEN
43 cycle
44 ENDIF
45 ENDIF
46 val_root( indrow, indcol ) =
47 & val_root( indrow, indcol ) + val_son(j,i)
48 END DO
49 DO j = ncol_son-nsupcol+1, ncol_son
50 indcol = indcol_son(j)
51 rhs_root( indrow, indcol ) =
52 & rhs_root( indrow, indcol ) + val_son(j,i)
53 ENDDO
54 END DO
55 ELSE
56 DO i=1, nrow_son
57 DO j = 1, ncol_son
58 rhs_root( indrow_son( i ), indcol_son(j)) =
59 & rhs_root(indrow_son(i),indcol_son(j)) + val_son(j,i)
60 ENDDO
61 ENDDO
62 ENDIF
63 RETURN

◆ zmumps_build_and_send_cb_root()

recursive subroutine zmumps_build_and_send_cb_root ( integer comm_load,
integer ass_irecv,
integer n,
integer ison,
integer iroot,
integer, dimension( keep(28) ) ptri,
integer(8), dimension( keep(28) ) ptrr,
type (zmumps_root_struc) root,
integer nbrow,
integer nbcol,
integer shift_list_row_son,
integer shift_list_col_son,
integer(8), intent(in) shift_val_son_arg,
integer, intent(in) lda_arg,
integer tag,
integer myid,
integer comm,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer, dimension( keep(28) ) procnode_steps,
integer(8) posfac,
integer iwpos,
integer iwposcb,
integer(8) iptrlu,
integer(8) lrlu,
integer(8) lrlus,
integer, dimension( liw ) iw,
integer liw,
complex(kind=8), dimension( la ) a,
integer(8) la,
integer, dimension( keep(28) ) ptrist,
integer, dimension(keep(28)) ptlust_s,
integer(8), dimension(keep(28)) ptrfac,
integer(8), dimension(keep(28)) ptrast,
integer, dimension(n) step,
integer, dimension(keep(28)) pimaster,
integer(8), dimension(keep(28)) pamaster,
integer, dimension( n ) nstk,
integer comp,
integer iflag,
integer ierror,
integer, dimension(n) perm,
integer, dimension( lpool ) ipool,
integer lpool,
integer leaf,
integer nbfin,
integer slavef,
double precision opassw,
double precision opeliw,
integer, dimension( n + keep(253) ) itloc,
complex(kind=8), dimension(keep(255)) rhs_mumps,
integer, dimension( n ) fils,
integer, dimension(keep(28)) dad,
integer(8), dimension( lptrar ), intent(in) ptrarw,
integer(8), dimension( lptrar ), intent(in) ptraiw,
integer, dimension( keep8(27) ) intarr,
complex(kind=8), dimension( keep8(26) ) dblarr,
integer, dimension(60) icntl,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230) dkeep,
logical transpose_asm,
integer, dimension( keep(28) ) nd,
integer, dimension( keep(28) ) frere,
integer lptrar,
integer nelt,
integer, dimension( n+1 ) frtptr,
integer, dimension( nelt ) frtelt,
integer, dimension(keep(71)) istep_to_iniv2,
integer, dimension(slavef+2,max(1,keep(56))) tab_pos_in_pere,
integer, dimension(n), intent(in) lrgroups )

Definition at line 65 of file ztype3_root.F.

84 USE zmumps_ooc
85 USE zmumps_buf
86 USE zmumps_load
87 USE zmumps_struc_def, ONLY : zmumps_root_struc
88 USE zmumps_dynamic_memory_m, ONLY : zmumps_dm_set_dynptr
89 IMPLICIT NONE
90 INTEGER KEEP(500), ICNTL(60)
91 INTEGER(8) KEEP8(150)
92 DOUBLE PRECISION DKEEP(230)
93 TYPE (ZMUMPS_ROOT_STRUC) :: root
94 INTEGER COMM_LOAD, ASS_IRECV
95 INTEGER N, ISON, IROOT, TAG
96 INTEGER PTRI( KEEP(28) )
97 INTEGER(8) :: PTRR( KEEP(28) )
98 INTEGER NBROW, NBCOL
99 INTEGER, INTENT(IN):: LDA_ARG
100 INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG
101 INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON
102 INTEGER MYID, COMM
103 LOGICAL TRANSPOSE_ASM
104 include 'mpif.h'
105 INTEGER LBUFR, LBUFR_BYTES
106 INTEGER BUFR( LBUFR )
107 INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA
108 INTEGER IWPOS, IWPOSCB
109 INTEGER LIW
110 INTEGER IW( LIW )
111 COMPLEX(kind=8) A( LA )
112 INTEGER, intent(in) :: LRGROUPS(N)
113 INTEGER LPTRAR, NELT
114 INTEGER FRTPTR( N+1 ), FRTELT( NELT )
115 INTEGER(8) :: PTRAST(KEEP(28))
116 INTEGER(8) :: PTRFAC(KEEP(28))
117 INTEGER(8) :: PAMASTER(KEEP(28))
118 INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28))
119 INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N )
120 INTEGER COMP, IFLAG, IERROR
121 INTEGER PERM(N)
122 INTEGER LPOOL, LEAF
123 INTEGER IPOOL( LPOOL )
124 INTEGER NBFIN, SLAVEF
125 DOUBLE PRECISION OPASSW, OPELIW
126 INTEGER PROCNODE_STEPS( KEEP(28) )
127 INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28))
128 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
129 INTEGER ND( KEEP(28) ), FRERE( KEEP(28) )
130 INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
131 INTEGER INTARR( KEEP8(27) )
132 COMPLEX(kind=8) DBLARR( KEEP8(26) )
133 INTEGER ISTEP_TO_INIV2(KEEP(71)),
134 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
135 COMPLEX(kind=8), DIMENSION(:), POINTER :: SONA_PTR
136 INTEGER(8) :: LSONA_PTR, POSSONA_PTR
137 INTEGER allocok
138 INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL
139 INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL
140 INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST
141 INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST
142 INTEGER :: STATUS(MPI_STATUS_SIZE)
143 INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB
144 INTEGER PDEST, IERR
145 INTEGER LOCAL_M, LOCAL_N
146 INTEGER(8) :: POSROOT
147 INTEGER NSUBSET_ROW, NSUBSET_COL
148 INTEGER NRLOCAL, NCLOCAL
149 INTEGER :: LDA
150 INTEGER(8) :: SHIFT_VAL_SON
151 LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED
152 INTEGER NBROWS_ALREADY_SENT
153 INTEGER SIZE_MSG
154 INTEGER LP
155 include 'mumps_headers.h'
156 LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY
157 INTEGER BBPCBP
158 INTEGER MUMPS_PROCNODE
159 EXTERNAL mumps_procnode
160 bbpcbp = 0
161 lp = icntl(1)
162 IF ( icntl(4) .LE. 0 ) lp = -1
163 IF (lda_arg < 0) THEN
164 CALL zmumps_set_lda_shift_val_son(iw, liw, ptri(step(ison)),
165 & lda, shift_val_son)
166 ELSE
167 lda = lda_arg
168 shift_val_son = shift_val_son_arg
169 ENDIF
170 ALLOCATE(ptrrow(root%NPROW + 1 ), stat=allocok)
171 if (allocok .GT. 0) THEN
172 iflag =-13
173 ierror = root%NPROW + 1
174 endif
175 ALLOCATE(ptrcol(root%NPCOL + 1 ), stat=allocok)
176 if (allocok .GT. 0) THEN
177 iflag =-13
178 ierror = root%NPCOL + 1
179 endif
180 ALLOCATE(nsuprow(root%NPROW + 1 ), stat=allocok)
181 if (allocok .GT. 0) THEN
182 iflag =-13
183 ierror = root%NPROW + 1
184 endif
185 ALLOCATE(nsupcol(root%NPCOL + 1 ), stat=allocok)
186 if (allocok .GT. 0) THEN
187 iflag =-13
188 ierror = root%NPCOL + 1
189 endif
190 IF (iflag.LT.0) THEN
191 IF (lp > 0) write(6,*) myid, ' : MEMORY ALLOCATION ',
192 & 'FAILURE in ZMUMPS_BUILD_AND_SEND_CB_ROOT'
193 CALL zmumps_bdc_error( myid, slavef, comm, keep )
194 RETURN
195 ENDIF
196 skiplast_rhs_rows = ((keep(253).GT.0).AND.(keep(50).EQ.0))
197 bcp_sym_nonempty = .false.
198 ptrrow = 0
199 ptrcol = 0
200 nsuprow = 0
201 nsupcol = 0
202 DO i = 1, nbrow
203 iglob = iw( ptri(step(ison)) +
204 & shift_list_row_son + i - 1 )
205 IF (skiplast_rhs_rows.AND.(iglob.GT.n)) cycle
206 IF ( .NOT. transpose_asm ) THEN
207 IF (iglob.GT.n) THEN
208 bcp_sym_nonempty = .true.
209 pos_in_root = iglob - n
210 jcol = mod((pos_in_root-1)/root%NBLOCK,root%NPCOL)
211 nsupcol(jcol+1) = nsupcol(jcol+1) + 1
212 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
213 ELSE
214 pos_in_root = root%RG2L_ROW( iglob )
215 irow = mod((pos_in_root-1)/root%MBLOCK,root%NPROW)
216 ptrrow( irow + 2 ) = ptrrow( irow + 2 ) + 1
217 ENDIF
218 ELSE
219 IF (iglob .GT. n) THEN
220 pos_in_root = iglob - n
221 ELSE
222 pos_in_root = root%RG2L_COL( iglob )
223 ENDIF
224 jcol = mod( ( pos_in_root - 1 ) / root%NBLOCK, root%NPCOL )
225 IF (iglob.GT.n)
226 & nsupcol(jcol+1) = nsupcol(jcol+1) + 1
227 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
228 END IF
229 END DO
230 IF (keep(50).NE.0 .AND.(.NOT.transpose_asm).AND.bcp_sym_nonempty)
231 & bbpcbp = 1
232 DO i = 1, nbcol
233 jglob = iw( ptri(step(ison)) +
234 & shift_list_col_son + i - 1 )
235 IF ((keep(50).GT.0) .AND. (jglob.GT.n)) cycle
236 IF ( .NOT. transpose_asm ) THEN
237 IF (keep(50).EQ.0) THEN
238 IF (jglob.LE.n) THEN
239 pos_in_root = root%RG2L_COL(jglob)
240 ELSE
241 pos_in_root = jglob-n
242 ENDIF
243 jcol = mod((pos_in_root-1) / root%NBLOCK, root%NPCOL )
244 IF (jglob.GT.n) THEN
245 nsupcol(jcol+1) = nsupcol(jcol+1) + 1
246 ENDIF
247 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
248 ELSE
249 pos_in_root = root%RG2L_COL(jglob)
250 jcol = mod((pos_in_root-1) / root%NBLOCK, root%NPCOL )
251 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
252 IF (bcp_sym_nonempty) THEN
253 pos_in_root = root%RG2L_ROW(jglob)
254 irow = mod((pos_in_root-1)/root%MBLOCK,root%NPROW)
255 nsuprow(irow+1) = nsuprow(irow+1)+1
256 ptrrow( irow + 2 ) = ptrrow( irow + 2 ) + 1
257 ENDIF
258 ENDIF
259 ELSE
260 IF (jglob.LE.n) THEN
261 pos_in_root = root%RG2L_ROW( jglob )
262 ELSE
263 pos_in_root = jglob-n
264 ENDIF
265 irow = mod( ( pos_in_root - 1 ) /
266 & root%MBLOCK, root%NPROW )
267 ptrrow( irow + 2 ) = ptrrow( irow + 2 ) + 1
268 END IF
269 END DO
270 ptrrow( 1 ) = 1
271 DO irow = 2, root%NPROW + 1
272 ptrrow( irow ) = ptrrow( irow ) + ptrrow( irow - 1 )
273 END DO
274 ptrcol( 1 ) = 1
275 DO jcol = 2, root%NPCOL + 1
276 ptrcol( jcol ) = ptrcol( jcol ) + ptrcol( jcol - 1 )
277 END DO
278 ALLOCATE(row_index_list(ptrrow(root%NPROW+1)-1+1),
279 & stat=allocok)
280 if (allocok .GT. 0) THEN
281 iflag =-13
282 ierror = ptrrow(root%NPROW+1)-1+1
283 endif
284 ALLOCATE(col_index_list(ptrcol(root%NPCOL+1)-1+1),
285 & stat=allocok)
286 if (allocok .GT. 0) THEN
287 iflag =-13
288 ierror = ptrcol(root%NPCOL+1)-1+1
289 endif
290 DO i = 1, nbrow
291 iglob = iw( ptri(step(ison)) +
292 & shift_list_row_son + i - 1 )
293 IF (skiplast_rhs_rows.AND.(iglob.GT.n)) cycle
294 IF ( .NOT. transpose_asm ) THEN
295 IF (iglob.GT.n) cycle
296 pos_in_root = root%RG2L_ROW( iglob )
297 irow = mod( ( pos_in_root - 1 ) / root%MBLOCK,
298 & root%NPROW )
299 row_index_list( ptrrow( irow + 1 ) ) = i
300 ptrrow( irow + 1 ) = ptrrow( irow + 1 ) + 1
301 ELSE
302 IF (iglob.LE.n) THEN
303 pos_in_root = root%RG2L_COL( iglob )
304 ELSE
305 pos_in_root = iglob - n
306 ENDIF
307 jcol = mod( ( pos_in_root - 1 ) / root%NBLOCK,
308 & root%NPCOL )
309 col_index_list( ptrcol( jcol + 1 ) ) = i
310 ptrcol( jcol + 1 ) = ptrcol( jcol + 1 ) + 1
311 END IF
312 END DO
313 DO i = 1, nbcol
314 jglob = iw( ptri(step(ison))+shift_list_col_son+i - 1 )
315 IF ((keep(50).GT.0) .AND. (jglob.GT.n)) cycle
316 IF ( .NOT. transpose_asm ) THEN
317 IF ( jglob.LE.n ) THEN
318 pos_in_root = root%RG2L_COL( jglob )
319 ELSE
320 pos_in_root = jglob - n
321 ENDIF
322 jcol = mod( ( pos_in_root - 1 ) /
323 & root%NBLOCK, root%NPCOL )
324 col_index_list( ptrcol( jcol + 1 ) ) = i
325 ptrcol( jcol + 1 ) = ptrcol( jcol + 1 ) + 1
326 ELSE
327 IF ( jglob.LE.n ) THEN
328 pos_in_root = root%RG2L_ROW( jglob )
329 ELSE
330 pos_in_root = jglob - n
331 ENDIF
332 irow = mod( ( pos_in_root - 1 ) /
333 & root%MBLOCK, root%NPROW )
334 row_index_list( ptrrow( irow + 1 ) ) = i
335 ptrrow( irow + 1 ) = ptrrow( irow + 1 ) + 1
336 END IF
337 END DO
338 IF (bcp_sym_nonempty) THEN
339 DO i = 1, nbrow
340 iglob = iw( ptri(step(ison)) +
341 & shift_list_row_son + i - 1 )
342 IF (iglob.LE.n) cycle
343 pos_in_root = iglob - n
344 jcol = mod((pos_in_root-1)/root%NBLOCK,root%NPCOL)
345 col_index_list( ptrcol( jcol + 1 ) ) = i
346 ptrcol( jcol + 1 ) = ptrcol( jcol + 1 ) + 1
347 ENDDO
348 DO i=1, nbcol
349 jglob = iw( ptri(step(ison))+shift_list_col_son+i - 1 )
350 IF (jglob.GT.n) THEN
351 EXIT
352 ELSE
353 pos_in_root = root%RG2L_ROW(jglob)
354 ENDIF
355 irow = mod((pos_in_root-1)/root%MBLOCK,root%NPROW)
356 row_index_list( ptrrow( irow + 1 ) ) = i
357 ptrrow( irow + 1 ) = ptrrow( irow + 1 ) + 1
358 ENDDO
359 ENDIF
360 DO irow = root%NPROW, 2, -1
361 ptrrow( irow ) = ptrrow( irow - 1 )
362 END DO
363 ptrrow( 1 ) = 1
364 DO jcol = root%NPCOL, 2, -1
365 ptrcol( jcol ) = ptrcol( jcol - 1 )
366 END DO
367 ptrcol( 1 ) = 1
368 jcol = root%MYCOL
369 irow = root%MYROW
370 IF ( root%yes ) THEN
371 if (irow .ne. root%MYROW .or. jcol.ne.root%MYCOL) then
372 write(*,*) ' error in grid position buildandsendcbroot'
373 CALL mumps_abort()
374 end if
375 IF ( ptrist(step(iroot)).EQ.0.AND.
376 & ptlust_s(step(iroot)).EQ.0) THEN
377 CALL zmumps_root_alloc_static(root, iroot, n, iw, liw,
378 & a, la,
379 & fils, dad, myid, slavef, procnode_steps,
380 & lptrar, nelt, frtptr, frtelt,
381 & ptraiw, ptrarw, intarr, dblarr,
382 & lrlu, iptrlu,
383 & iwpos, iwposcb, ptrist, ptrast,
384 & step, pimaster, pamaster, itloc, rhs_mumps,
385 & comp, lrlus, iflag, keep,keep8,dkeep, ierror )
386 keep(121) = -1
387 IF (iflag.LT.0) THEN
388 CALL zmumps_bdc_error( myid, slavef, comm, keep )
389 RETURN
390 ENDIF
391 ELSE
392 keep(121) = keep(121) - 1
393 IF ( keep(121) .eq. 0 ) THEN
394 IF (keep(201).EQ.1) THEN
395 CALL zmumps_ooc_force_wrt_buf_panel(ierr)
396 ELSE IF (keep(201).EQ.2) THEN
397 CALL zmumps_force_write_buf(ierr)
398 ENDIF
399 CALL zmumps_insert_pool_n(n, ipool, lpool, procnode_steps,
400 & slavef, keep(199), keep(28), keep(76), keep(80), keep(47),
401 & step, iroot+n )
402 IF (keep(47) .GE. 3) THEN
403 CALL zmumps_load_pool_upd_new_pool(
404 & ipool, lpool,
405 & procnode_steps, keep,keep8, slavef, comm_load,
406 & myid, step, n, nd, fils )
407 ENDIF
408 END IF
409 END IF
410 CALL zmumps_dm_set_dynptr( iw(ptri(step(ison))+xxs), a, la,
411 & ptrr(step(ison)), iw(ptri(step(ison))+xxd),
412 & iw(ptri(step(ison))+xxr),
413 & sona_ptr, possona_ptr, lsona_ptr )
414 IF (keep(60) .NE. 0 ) THEN
415 local_m = root%SCHUR_LLD
416 local_n = root%SCHUR_NLOC
417 nrlocal = ptrrow( irow + 2 ) - ptrrow( irow + 1 )
418 nclocal = ptrcol( jcol + 2 ) - ptrcol( jcol + 1 )
419 CALL zmumps_root_local_assembly( n,
420 & root%SCHUR_POINTER(1),
421 & local_m, local_n,
422 & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK,
423 & nbcol, nbrow,
424 & iw( ptri(step(ison)) + shift_list_col_son ),
425 & iw( ptri(step(ison)) + shift_list_row_son ),
426 & lda, sona_ptr( possona_ptr + shift_val_son ),
427 & row_index_list( ptrrow( irow + 1 ) ),
428 & col_index_list( ptrcol( jcol + 1 ) ),
429 & nrlocal,
430 & nclocal,
431 & nsuprow(irow+1), nsupcol(jcol+1),
432 & root%RG2L_ROW(1), root%RG2L_COL(1), transpose_asm,
433 & keep,
434 & root%RHS_ROOT(1,1), root%RHS_NLOC )
435 ELSE
436 IF ( ptrist(step( iroot )) .GE. 0 ) THEN
437 IF ( ptrist(step( iroot )) .EQ. 0 ) THEN
438 local_n = iw( ptlust_s(step(iroot)) + 1 + keep(ixsz))
439 local_m = iw( ptlust_s(step(iroot)) + 2 + keep(ixsz))
440 posroot = ptrfac(iw( ptlust_s(step(iroot)) +4+keep(ixsz) ))
441 ELSE
442 local_n = - iw( ptrist(step(iroot)) +keep(ixsz))
443 local_m = iw( ptrist(step(iroot)) + 1 +keep(ixsz))
444 posroot = pamaster(step( iroot ))
445 ENDIF
446 nclocal = ptrcol( jcol + 2 ) - ptrcol( jcol + 1 )
447 nrlocal = ptrrow( irow + 2 ) - ptrrow( irow + 1 )
448 CALL zmumps_root_local_assembly( n, a( posroot ),
449 & local_m, local_n,
450 & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK,
451 & nbcol, nbrow,
452 & iw( ptri(step(ison)) + shift_list_col_son ),
453 & iw( ptri(step(ison)) + shift_list_row_son ),
454 & lda, sona_ptr( possona_ptr + shift_val_son ),
455 & row_index_list( ptrrow( irow + 1 ) ),
456 & col_index_list( ptrcol( jcol + 1 ) ),
457 & nrlocal,
458 & nclocal,
459 & nsuprow(irow+1), nsupcol(jcol+1),
460 & root%RG2L_ROW(1), root%RG2L_COL(1), transpose_asm,
461 & keep,
462 & root%RHS_ROOT(1,1), root%RHS_NLOC )
463 END IF
464 ENDIF
465 END IF
466 DO irow = 0, root%NPROW - 1
467 DO jcol = 0, root%NPCOL - 1
468 pdest = irow * root%NPCOL + jcol
469 IF ( (root%MYROW.eq.irow.and.root%MYCOL.eq.jcol) .and.
470 & myid.ne.pdest) THEN
471 write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL
472 write(*,*) ' MYID,PDEST=',myid,pdest
473 CALL mumps_abort()
474 END IF
475 IF ( root%MYROW .NE. irow .OR. root%MYCOL .NE. jcol) THEN
476 nbrows_already_sent = 0
477 ierr = -1
478 DO WHILE ( ierr .EQ. -1 )
479 nsubset_row = ptrrow( irow + 2 ) - ptrrow( irow + 1 )
480 nsubset_col = ptrcol( jcol + 2 ) - ptrcol( jcol + 1 )
481 IF ( lrlu .LT. int(nsubset_row,8) * int(nsubset_col,8)
482 & .AND. lrlus .GT. int(nsubset_row,8) * int(nsubset_col,8) )
483 & THEN
484 CALL zmumps_compre_new(n, keep,
485 & iw, liw, a, la,
486 & lrlu, iptrlu,
487 & iwpos, iwposcb, ptrist, ptrast,
488 & step, pimaster, pamaster, lrlus,
489 & keep(ixsz), comp, dkeep(97),
490 & myid, slavef, procnode_steps, dad)
491 IF ( lrlu .NE. lrlus ) THEN
492 WRITE(*,*) myid,": pb compress in",
493 & "ZMUMPS_BUILD_AND_SEND_CB_ROOT"
494 WRITE(*,*) myid,': LRLU, LRLUS=',lrlu,lrlus
495 CALL mumps_abort()
496 END IF
497 END IF
498 CALL zmumps_dm_set_dynptr(
499 & iw(ptri(step(ison))+xxs), a, la,
500 & ptrr(step(ison)), iw(ptri(step(ison))+xxd),
501 & iw(ptri(step(ison))+xxr),
502 & sona_ptr, possona_ptr, lsona_ptr )
503 CALL zmumps_buf_send_contrib_type3_i( n, ison,
504 & nbcol, nbrow,
505 & iw( ptri(step(ison)) + shift_list_col_son ),
506 & iw( ptri(step(ison)) + shift_list_row_son ),
507 & lda, sona_ptr( possona_ptr + shift_val_son ),
508 & tag,
509 & row_index_list( ptrrow( irow + 1 ) ),
510 & col_index_list( ptrcol( jcol + 1 ) ),
511 & nsubset_row, nsubset_col,
512 & nsuprow(irow+1), nsupcol(jcol+1),
513 & root%NPROW, root%NPCOL, root%MBLOCK,
514 & root%RG2L_ROW(1), root%RG2L_COL(1),
515 & root%NBLOCK, pdest,
516 & comm, ierr, a( posfac ), lrlu, transpose_asm,
517 & size_msg, nbrows_already_sent, keep, bbpcbp )
518 IF ( ierr .EQ. -1 ) THEN
519 blocking = .false.
520 set_irecv = .true.
521 message_received = .false.
522 CALL zmumps_try_recvtreat( comm_load, ass_irecv,
523 & blocking, set_irecv, message_received,
524 & mpi_any_source, mpi_any_tag,
525 & status, bufr, lbufr,
526 & lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb,
527 & iptrlu, lrlu, lrlus, n, iw, liw, a, la,
528 & ptrist, ptlust_s, ptrfac, ptrast, step,
529 & pimaster, pamaster, nstk,
530 & comp, iflag, ierror, comm, perm, ipool, lpool,
531 & leaf, nbfin, myid, slavef, root,
532 & opassw, opeliw, itloc, rhs_mumps, fils, dad,
533 & ptrarw,ptraiw,intarr,dblarr,icntl,keep,keep8,dkeep,
534 & nd, frere, lptrar, nelt, frtptr, frtelt,
535 & istep_to_iniv2, tab_pos_in_pere, .true.
536 & , lrgroups
537 & )
538 IF ( iflag .LT. 0 ) GOTO 500
539 IF (lda_arg < 0) THEN
540 CALL zmumps_set_lda_shift_val_son(
541 & iw, liw, ptri(step(ison)),
542 & lda, shift_val_son)
543 ENDIF
544 END IF
545 END DO
546 IF ( ierr == -2 ) THEN
547 iflag = -17
548 ierror = size_msg
549 IF (lp > 0) WRITE(lp, *) "FAILURE, SEND BUFFER TOO
550 & SMALL DURING ZMUMPS_BUILD_AND_SEND_CB_ROOT"
551 CALL zmumps_bdc_error( myid, slavef, comm, keep )
552 GOTO 500
553 ENDIF
554 IF ( ierr == -3 ) THEN
555 IF (lp > 0) WRITE(lp, *) "FAILURE, RECV BUFFER TOO
556 & SMALL DURING ZMUMPS_BUILD_AND_SEND_CB_ROOT"
557 iflag = -20
558 ierror = size_msg
559 CALL zmumps_bdc_error( myid, slavef, comm, keep )
560 GOTO 500
561 ENDIF
562 END IF
563 END DO
564 END DO
565 500 CONTINUE
566 DEALLOCATE(ptrrow)
567 DEALLOCATE(ptrcol)
568 DEALLOCATE(row_index_list)
569 DEALLOCATE(col_index_list)
570 RETURN
571 CONTAINS
572 SUBROUTINE zmumps_set_lda_shift_val_son(IW, LIW, IOLDPS,
573 & LDA, SHIFT_VAL_SON)
574 INTEGER, INTENT(IN) :: LIW, IOLDPS
575 INTEGER, INTENT(IN) :: IW(LIW)
576 INTEGER, INTENT(OUT) :: LDA
577 INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON
578 include 'mumps_headers.h'
579 INTEGER :: LCONT, NROW, NPIV, NASS, NELIM
580 lcont = iw(ioldps+keep(ixsz))
581 nrow = iw(ioldps+2+keep(ixsz))
582 npiv = iw(ioldps+3+keep(ixsz))
583 nass = iw(ioldps+4+keep(ixsz))
584 nelim = nass-npiv
585 IF (iw(ioldps+xxs).EQ.s_nolcbnocontig38.OR.
586 & iw(ioldps+xxs).EQ.s_all) THEN
587 shift_val_son = int(npiv,8)
588 lda = lcont + npiv
589 ELSE IF (iw(ioldps+xxs).EQ.s_nolcbcontig38) THEN
590 shift_val_son = int(nrow,8)*int(lcont+npiv-nelim,8)
591 lda = nelim
592 ELSE IF (iw(ioldps+xxs).EQ.s_nolcleaned38) THEN
593 shift_val_son=0_8
594 lda = nelim
595 ELSE
596 WRITE(*,*) myid,
597 & ": internal error in ZMUMPS_SET_LDA_SHIFT_VAL_SON",
598 & iw(ioldps+xxs), "ISON=",ison
599 CALL mumps_abort()
600 ENDIF
601 RETURN
602 END SUBROUTINE zmumps_set_lda_shift_val_son
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
zmumps_buf
Definition zmumps_comm_buffer.F:14
zmumps_dynamic_memory_m
Definition zfac_mem_dynamic.F:14
zmumps_dynamic_memory_m::zmumps_dm_set_dynptr
subroutine zmumps_dm_set_dynptr(cb_state, a, la, pamaster_or_ptrast, ixxd, ixxr, son_a, iachk, recsize)
Definition zfac_mem_dynamic.F:19
zmumps_load
Definition zmumps_load.F:14
zmumps_load::myid
integer, save, private myid
Definition zmumps_load.F:57
zmumps_load::zmumps_load_pool_upd_new_pool
subroutine, public zmumps_load_pool_upd_new_pool(pool, lpool, procnode, keep, keep8, slavef, comm, myid, step, n, nd, fils)
Definition zmumps_load.F:1820
zmumps_ooc
Definition zmumps_ooc.F:14
zmumps_ooc::zmumps_ooc_force_wrt_buf_panel
subroutine zmumps_ooc_force_wrt_buf_panel(ierr)
Definition zmumps_ooc.F:2965
zmumps_ooc::zmumps_force_write_buf
subroutine zmumps_force_write_buf(ierr)
Definition zmumps_ooc.F:2951
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
zmumps_bdc_error
subroutine zmumps_bdc_error(myid, slavef, comm, keep)
Definition zbcast_int.F:38
zmumps_compre_new
subroutine zmumps_compre_new(n, keep, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad)
Definition zfac_mem_compress_cb.F:120
zmumps_try_recvtreat
recursive subroutine zmumps_try_recvtreat(comm_load, ass_irecv, blocking, set_irecv, message_received, msgsou, msgtag, status, bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptlust, ptrfac, ptrast, step, pimaster, pamaster, nstk_s, comp, iflag, ierror, comm, perm, ipool, lpool, leaf, nbfin, myid, slavef root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, nd, frere, lptrar, nelt, frtptr, frtelt istep_to_iniv2, tab_pos_in_pere, stack_right_authorized, lrgroups)
Definition zfac_process_message.F:560
zmumps_insert_pool_n
subroutine zmumps_insert_pool_n(n, pool, lpool, procnode, slavef, keep199, k28, k76, k80, k47, step, inode)
Definition zfac_sol_pool.F:27
zmumps_buf_send_contrib_type3_i
subroutine zmumps_buf_send_contrib_type3_i(n, ison, nbcol_son, nbrow_son, indcol_son, indrow_son, ld_son, val_son, tag, subset_row, subset_col, nsubset_row, nsubset_col, nsuprow, nsupcol, nprow, npcol, mblock, rg2l_row, rg2l_col, nblock, pdest, comm, ierr, tab, tabsize, transp, size_pack, n_already_sent, keep, bbpcbp)
Definition ztools.F:1883
zmumps_root_alloc_static
subroutine zmumps_root_alloc_static(root, iroot, n, iw, liw, a, la, fils, dad, myid, slavef, procnode_steps, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, itloc, rhs_mumps, comp, lrlus, iflag, keep, keep8, dkeep, ierror)
Definition ztype3_root.F:1089
zmumps_set_lda_shift_val_son
subroutine zmumps_set_lda_shift_val_son(iw, liw, ioldps, lda, shift_val_son)
Definition ztype3_root.F:574
zmumps_root_local_assembly
subroutine zmumps_root_local_assembly(n, val_root, local_m, local_n, npcol, nprow, mblock, nblock, nbcol_son, nbrow_son, indcol_son, indrow_son, ld_son, val_son, subset_row, subset_col, nsubset_row, nsubset_col, nsuprow, nsupcol, rg2l_row, rg2l_col, transpose_asm, keep, rhs_root, nloc)
Definition ztype3_root.F:611

◆ zmumps_def_grid()

subroutine zmumps_def_grid ( integer nprocs,
integer nprow,
integer npcol,
integer size,
integer k50 )

Definition at line 868 of file ztype3_root.F.

869 IMPLICIT NONE
870 INTEGER NPROCS, NPROW, NPCOL, SIZE, K50
871 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS
872 LOGICAL KEEPIT
873 IF ( k50 .EQ. 1 ) THEN
874 flatness = 2
875 ELSE
876 flatness = 3
877 ENDIF
878 nprow = int(sqrt(dble(nprocs)))
879 nprowtemp = nprow
880 npcol = int(nprocs / nprow)
881 npcoltemp = npcol
882 nprocsused = nprowtemp * npcoltemp
883 10 CONTINUE
884 IF ( nprowtemp >= npcoltemp/flatness .AND. nprowtemp > 1) THEN
885 nprowtemp = nprowtemp - 1
886 npcoltemp = int(nprocs / nprowtemp)
887 keepit=.false.
888 IF ( nprowtemp * npcoltemp .GE. nprocsused ) THEN
889 IF ( ( k50 .NE. 1 .AND. nprowtemp >= npcoltemp/flatness)
890 & .OR. nprowtemp * npcoltemp .GT. nprocsused )
891 & keepit=.true.
892 END IF
893 IF ( keepit ) THEN
894 nprow = nprowtemp
895 npcol = npcoltemp
896 nprocsused = nprow * npcol
897 END IF
898 GO TO 10
899 END IF
900 RETURN

◆ zmumps_gather_root()

subroutine zmumps_gather_root ( integer myid,
integer m,
integer n,
complex(kind=8), dimension( m, n ) aseq,
integer local_m,
integer local_n,
integer mblock,
integer nblock,
complex(kind=8), dimension( local_m, local_n ) apar,
integer master_root,
integer nprow,
integer npcol,
integer comm )

Definition at line 991 of file ztype3_root.F.

998 IMPLICIT NONE
999 INTEGER MYID, MASTER_ROOT, COMM
1000 INTEGER M, N
1001 INTEGER NPROW, NPCOL
1002 INTEGER LOCAL_M, LOCAL_N
1003 INTEGER MBLOCK, NBLOCK
1004 COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N )
1005 COMPLEX(kind=8) ASEQ( M, N )
1006 include 'mpif.h'
1007 INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL
1008 INTEGER IBLOCK, JBLOCK, II, JJ, KK
1009 INTEGER IAPAR, JAPAR, IERR, allocok
1010 INTEGER :: STATUS(MPI_STATUS_SIZE)
1011 COMPLEX(kind=8),DIMENSION(:), ALLOCATABLE :: WK
1012 LOGICAL JUPDATE
1013 ALLOCATE(wk( mblock * nblock ), stat=allocok)
1014 if(allocok.ne.0) then
1015 WRITE(6,*) ' Allocation error of WK in '
1016 & // 'routine ZMUMPS_GATHER_ROOT '
1017 CALL mumps_abort()
1018 endif
1019 iapar = 1
1020 japar = 1
1021 DO j = 1, n, nblock
1022 size_jblock = nblock
1023 IF ( j + nblock > n ) THEN
1024 size_jblock = n - j + 1
1025 END IF
1026 jupdate = .false.
1027 DO i = 1, m, mblock
1028 size_iblock = mblock
1029 IF ( i + mblock > m ) THEN
1030 size_iblock = m - i + 1
1031 END IF
1032 iblock = i / mblock
1033 jblock = j / nblock
1034 irow = mod( iblock, nprow )
1035 icol = mod( jblock, npcol )
1036 isour = irow * npcol + icol
1037 IF ( isour .NE. master_root ) THEN
1038 IF ( myid .EQ. master_root ) THEN
1039 CALL mpi_recv( wk(1), size_iblock*size_jblock,
1040 & mpi_double_complex,
1041 & isour, 128, comm, status, ierr )
1042 kk=1
1043 DO jj=j,j+size_jblock-1
1044 DO ii=i,i+size_iblock-1
1045 aseq(ii,jj)=wk(kk)
1046 kk=kk+1
1047 END DO
1048 END DO
1049 ELSE IF ( myid .EQ. isour ) THEN
1050 kk=1
1051 DO jj=japar,japar+size_jblock-1
1052 DO ii=iapar,iapar+size_iblock-1
1053 wk(kk)=apar(ii,jj)
1054 kk=kk+1
1055 END DO
1056 END DO
1057 CALL mpi_ssend( wk( 1 ),
1058 & size_iblock*size_jblock,
1059 & mpi_double_complex,
1060 & master_root,128,comm,ierr)
1061 jupdate = .true.
1062 iapar = iapar + size_iblock
1063 END IF
1064 ELSE IF ( myid.EQ. master_root ) THEN
1065 aseq(i:i+size_iblock-1,j:j+size_jblock-1)
1066 & = apar( iapar:iapar+size_iblock-1,
1067 & japar:japar+size_jblock-1 )
1068 jupdate = .true.
1069 iapar = iapar + size_iblock
1070 END IF
1071 END DO
1072 IF ( jupdate ) THEN
1073 iapar = 1
1074 japar = japar + size_jblock
1075 END IF
1076 END DO
1077 DEALLOCATE(wk)
1078 RETURN
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_ssend
subroutine mpi_ssend(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:491

◆ zmumps_init_root_ana()

subroutine zmumps_init_root_ana ( integer myid,
integer nprocs,
integer n,
type (zmumps_root_struc) root,
integer comm_root,
integer iroot,
integer, dimension( n ) fils,
integer k50,
integer k46,
integer k51,
integer k60,
integer idnprow,
integer idnpcol,
integer idmblock,
integer idnblock )

Definition at line 739 of file ztype3_root.F.

744 USE zmumps_struc_def, ONLY : zmumps_root_struc
745 IMPLICIT NONE
746 INTEGER MYID, MYID_ROOT
747 TYPE (ZMUMPS_ROOT_STRUC)::root
748 INTEGER COMM_ROOT
749 INTEGER N, IROOT, NPROCS, K50, K46, K51
750 INTEGER FILS( N )
751 INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK
752 INTEGER INODE, NPROWtemp, NPCOLtemp
753 LOGICAL SLAVE
754 root%ROOT_SIZE = 0
755 root%TOT_ROOT_SIZE = 0
756 slave = ( myid .ne. 0 .or.
757 & ( myid .eq. 0 .and. k46 .eq. 1 ) )
758 inode = iroot
759 DO WHILE ( inode .GT. 0 )
760 inode = fils( inode )
761 root%ROOT_SIZE = root%ROOT_SIZE + 1
762 END DO
763 IF ( ( k60 .NE. 2 .AND. k60 .NE. 3 ) .OR.
764 & idnprow .LE. 0 .OR. idnpcol .LE. 0
765 & .OR. idmblock .LE.0 .OR. idnblock.LE.0
766 & .OR. idnprow * idnpcol .GT. nprocs ) THEN
767 root%MBLOCK = k51
768 root%NBLOCK = k51
769 CALL zmumps_def_grid( nprocs, root%NPROW, root%NPCOL,
770 & root%ROOT_SIZE, k50 )
771 IF ( k60 .EQ. 2 .OR. k60 .EQ. 3 ) THEN
772 idnprow = root%NPROW
773 idnpcol = root%NPCOL
774 idmblock = root%MBLOCK
775 idnblock = root%NBLOCK
776 ENDIF
777 ELSE IF ( k60 .EQ. 2 .OR. k60 .EQ. 3 ) THEN
778 root%NPROW = idnprow
779 root%NPCOL = idnpcol
780 root%MBLOCK = idmblock
781 root%NBLOCK = idnblock
782 ENDIF
783 IF ( k60 .EQ. 2 .OR. k60 .EQ. 3 ) THEN
784 IF (slave) THEN
785 root%LPIV = 0
786 IF (k46.EQ.0) THEN
787 myid_root=myid-1
788 ELSE
789 myid_root=myid
790 ENDIF
791 IF (myid_root < root%NPROW*root%NPCOL) THEN
792 root%MYROW = myid_root / root%NPCOL
793 root%MYCOL = mod(myid_root, root%NPCOL)
794 root%yes = .true.
795 ELSE
796 root%MYROW = -1
797 root%MYCOL = -1
798 root%yes = .false.
799 ENDIF
800 ELSE
801 root%yes = .false.
802 ENDIF
803 ELSE IF ( slave ) THEN
804 IF ( root%gridinit_done) THEN
805 IF (root%yes) THEN
806 CALL blacs_gridexit( root%CNTXT_BLACS )
807 root%gridinit_done = .false.
808 ENDIF
809 END IF
810 root%CNTXT_BLACS = comm_root
811 CALL blacs_gridinit( root%CNTXT_BLACS, 'R',
812 & root%NPROW, root%NPCOL )
813 root%gridinit_done = .true.
814 CALL blacs_gridinfo( root%CNTXT_BLACS,
815 & nprowtemp, npcoltemp,
816 & root%MYROW, root%MYCOL )
817 IF ( root%MYROW .NE. -1 ) THEN
818 root%yes = .true.
819 ELSE
820 root%yes = .false.
821 END IF
822 root%LPIV = 0
823 ELSE
824 root%yes = .false.
825 ENDIF
826 RETURN
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
zmumps_def_grid
subroutine zmumps_def_grid(nprocs, nprow, npcol, size, k50)
Definition ztype3_root.F:869

◆ zmumps_init_root_fac()

subroutine zmumps_init_root_fac ( integer n,
type ( zmumps_root_struc ) root,
integer, dimension( n ) fils,
integer iroot,
integer, dimension(500) keep,
integer, dimension(80) info )

Definition at line 828 of file ztype3_root.F.

830 USE zmumps_struc_def, ONLY : zmumps_root_struc
831 IMPLICIT NONE
832 TYPE ( ZMUMPS_ROOT_STRUC ):: root
833 INTEGER N, IROOT, INFO(80), KEEP(500)
834 INTEGER FILS( N )
835 INTEGER INODE, I, allocok
836 IF ( associated( root%RG2L_ROW ) ) THEN
837 DEALLOCATE( root%RG2L_ROW )
838 NULLIFY( root%RG2L_ROW )
839 ENDIF
840 IF ( associated( root%RG2L_COL ) ) THEN
841 DEALLOCATE( root%RG2L_COL )
842 NULLIFY( root%RG2L_COL )
843 ENDIF
844 ALLOCATE( root%RG2L_ROW( n ), stat = allocok )
845 IF ( allocok .GT. 0 ) THEN
846 info(1)=-13
847 info(2)=n
848 RETURN
849 ENDIF
850 ALLOCATE( root%RG2L_COL( n ), stat = allocok )
851 IF ( allocok .GT. 0 ) THEN
852 DEALLOCATE( root%RG2L_ROW ); NULLIFY( root%RG2L_ROW )
853 info(1)=-13
854 info(2)=n
855 RETURN
856 ENDIF
857 inode = iroot
858 i = 1
859 DO WHILE ( inode .GT. 0 )
860 root%RG2L_ROW( inode ) = i
861 root%RG2L_COL( inode ) = i
862 i = i + 1
863 inode = fils( inode )
864 END DO
865 root%TOT_ROOT_SIZE=0
866 RETURN

◆ zmumps_root_alloc_static()

subroutine zmumps_root_alloc_static ( type (zmumps_root_struc ) root,
integer iroot,
integer n,
integer, dimension( liw ) iw,
integer liw,
complex(kind=8), dimension( la ) a,
integer(8) la,
integer, dimension( n ) fils,
integer, dimension(keep(28)) dad,
integer myid,
integer, intent(in) slavef,
integer, dimension(keep(28)), intent(in) procnode_steps,
integer lptrar,
integer nelt,
integer, dimension( n+1) frtptr,
integer, dimension( nelt ) frtelt,
integer(8), dimension( lptrar ), intent(in) ptraiw,
integer(8), dimension( lptrar ), intent(in) ptrarw,
integer, dimension(keep8(27)) intarr,
complex(kind=8), dimension(keep8(26)) dblarr,
integer(8) lrlu,
integer(8) iptrlu,
integer iwpos,
integer iwposcb,
integer, dimension(keep(28)) ptrist,
integer(8), dimension(keep(28)) ptrast,
integer, dimension(n) step,
integer, dimension(keep(28)) pimaster,
integer(8), dimension(keep(28)) pamaster,
integer, dimension( n + keep(253) ) itloc,
complex(kind=8), dimension(keep(255)) rhs_mumps,
integer comp,
integer(8) lrlus,
integer iflag,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230) dkeep,
integer ierror )

Definition at line 1080 of file ztype3_root.F.

1089 USE zmumps_struc_def, ONLY : zmumps_root_struc
1090 IMPLICIT NONE
1091 INTEGER MYID
1092 INTEGER KEEP(500)
1093 INTEGER(8) KEEP8(150)
1094 DOUBLE PRECISION DKEEP(230)
1095 TYPE (ZMUMPS_ROOT_STRUC ) :: root
1096 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS
1097 INTEGER IROOT, LIW, N, IWPOS, IWPOSCB
1098 INTEGER IW( LIW )
1099 COMPLEX(kind=8) A( LA )
1100 INTEGER, INTENT(IN) :: SLAVEF
1101 INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28))
1102 INTEGER PTRIST(KEEP(28)), STEP(N)
1103 INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28))
1104 INTEGER PIMASTER(KEEP(28))
1105 INTEGER ITLOC( N + KEEP(253) )
1106 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
1107 INTEGER COMP, IFLAG, IERROR
1108 include 'mumps_headers.h'
1109 INTEGER FILS( N ), DAD(KEEP(28))
1110 INTEGER LPTRAR, NELT
1111 INTEGER FRTPTR( N+1), FRTELT( NELT )
1112 INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR )
1113 INTEGER INTARR(KEEP8(27))
1114 COMPLEX(kind=8) DBLARR(KEEP8(26))
1115 INTEGER numroc
1116 EXTERNAL numroc
1117 COMPLEX(kind=8) ZERO
1118 parameter( zero = (0.0d0,0.0d0) )
1119 INTEGER(8) :: LREQA_ROOT
1120 INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok
1121 LOGICAL :: EARLYT3ROOTINS
1122 local_m = numroc( root%ROOT_SIZE, root%MBLOCK,
1123 & root%MYROW, 0, root%NPROW )
1124 local_m = max( 1, local_m )
1125 local_n = numroc( root%ROOT_SIZE, root%NBLOCK,
1126 & root%MYCOL, 0, root%NPCOL )
1127 IF (keep(253).GT.0) THEN
1128 root%RHS_NLOC = numroc( keep(253), root%NBLOCK,
1129 & root%MYCOL, 0, root%NPCOL )
1130 root%RHS_NLOC = max(1, root%RHS_NLOC)
1131 ELSE
1132 root%RHS_NLOC = 1
1133 ENDIF
1134 IF (associated( root%RHS_ROOT) )
1135 & DEALLOCATE (root%RHS_ROOT)
1136 ALLOCATE(root%RHS_ROOT(local_m,root%RHS_NLOC),
1137 & stat=allocok)
1138 IF ( allocok.GT.0) THEN
1139 iflag=-13
1140 ierror = local_m*root%RHS_NLOC
1141 RETURN
1142 ENDIF
1143 IF (keep(253).NE.0) THEN
1144 root%RHS_ROOT = zero
1145 CALL zmumps_asm_rhs_root ( n, fils,
1146 & root, keep, rhs_mumps,
1147 & iflag, ierror )
1148 IF ( iflag .LT. 0 ) RETURN
1149 ENDIF
1150 IF (keep(60) .NE. 0) THEN
1151 ptrist(step(iroot)) = -6666666
1152 ELSE
1153 lreqi_root = 2 + keep(ixsz)
1154 lreqa_root = int(local_m,8) * int(local_n,8)
1155 IF (lreqa_root.EQ.0_8) THEN
1156 ptrist(step(iroot)) = -9999999
1157 RETURN
1158 ENDIF
1159 CALL zmumps_alloc_cb(.false.,0_8,.false.,.false.,
1160 & myid,n,keep,keep8,dkeep,iw,liw,a,la,
1161 & lrlu, iptrlu,
1162 & iwpos, iwposcb, slavef, procnode_steps, dad,
1163 & ptrist, ptrast,
1164 & step, pimaster, pamaster, lreqi_root,
1165 & lreqa_root, iroot, s_notfree, .true., comp,
1166 & lrlus, keep8(67), iflag, ierror
1167 & )
1168 IF ( iflag .LT. 0 ) RETURN
1169 ptrist( step(iroot) ) = iwposcb + 1
1170 pamaster( step(iroot) ) = iptrlu + 1_8
1171 iw( iwposcb + 1 + keep(ixsz)) = - local_n
1172 iw( iwposcb + 2 + keep(ixsz)) = local_m
1173 ENDIF
1174 earlyt3rootins = keep(200) .EQ.0
1175 & .OR. ( keep(200) .LT. 0 .AND. keep(400) .EQ. 0 )
1176 IF (local_n > 0 .AND. .NOT. earlyt3rootins ) THEN
1177 IF (keep(60) .EQ. 0) THEN
1178 CALL zmumps_set_to_zero(a(iptrlu+1_8), local_m,
1179 & local_m, local_n, keep)
1180 ELSE
1181 CALL zmumps_set_to_zero(root%SCHUR_POINTER(1),
1182 & root%SCHUR_LLD, local_m, local_n, keep)
1183 ENDIF
1184 IF (keep(55) .eq. 0) THEN
1185 IF (keep(60) .EQ. 0) THEN
1186 CALL zmumps_asm_arr_root( n, root, iroot,
1187 & a(iptrlu+1_8), local_m, local_m, local_n,
1188 & fils, ptraiw, ptrarw, intarr, dblarr,
1189 & keep8(27), keep8(26), myid )
1190 ELSE
1191 CALL zmumps_asm_arr_root( n, root, iroot,
1192 & root%SCHUR_POINTER(1), root%SCHUR_LLD, local_m, local_n,
1193 & fils, ptraiw, ptrarw, intarr, dblarr,
1194 & keep8(27), keep8(26), myid )
1195 ENDIF
1196 ELSE
1197 IF (keep(60) .EQ. 0) THEN
1198 CALL zmumps_asm_elt_root( n, root,
1199 & a(iptrlu+1_8), local_m, local_m, local_n,
1200 & lptrar, nelt, frtptr, frtelt,
1201 & ptraiw, ptrarw, intarr, dblarr,
1202 & keep8(27), keep8(26), keep, keep8, myid )
1203 ELSE
1204 CALL zmumps_asm_elt_root( n, root,
1205 & root%SCHUR_POINTER(1), root%SCHUR_LLD,
1206 & root%SCHUR_MLOC, root%SCHUR_NLOC,
1207 & lptrar, nelt, frtptr, frtelt,
1208 & ptraiw, ptrarw, intarr, dblarr,
1209 & keep8(27), keep8(26), keep, keep8, myid )
1210 ENDIF
1211 ENDIF
1212 ENDIF
1213 RETURN
max
#define max(a, b)
Definition macros.h:21
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition mpi.f:786
zmumps_set_to_zero
subroutine zmumps_set_to_zero(a, lld, m, n, keep)
Definition zarrowheads.F:916
zmumps_alloc_cb
subroutine zmumps_alloc_cb(inplace, min_space_in_place, ssarbr, process_bande, myid, n, keep, keep8, dkeep, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, slavef, procnode_steps, dad, ptrist, ptrast, step, pimaster, pamaster, lreq, lreqcb, node_arg, state_arg, set_header, comp, lrlus, lrlusm, iflag, ierror)
Definition zfac_mem_alloc_cb.F:23
zmumps_asm_arr_root
subroutine zmumps_asm_arr_root(n, root, iroot, valroot, local_m_lld, local_m, local_n, fils, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, myid)
Definition ztype3_root.F:1335
zmumps_asm_rhs_root
subroutine zmumps_asm_rhs_root(n, fils, root, keep, rhs_mumps, iflag, ierror)
Definition ztype3_root.F:1298
zmumps_asm_elt_root
subroutine zmumps_asm_elt_root(n, root, valroot, local_m_lld, local_m, local_n, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, keep, keep8, myid)
Definition ztype3_root.F:1222

◆ zmumps_root_local_assembly()

subroutine zmumps_root_local_assembly ( integer n,
complex(kind=8), dimension( local_m, local_n ) val_root,
integer local_m,
integer local_n,
integer npcol,
integer nprow,
integer mblock,
integer nblock,
integer nbcol_son,
integer nbrow_son,
integer, dimension( nbcol_son ) indcol_son,
integer, dimension( nbrow_son ) indrow_son,
integer ld_son,
complex(kind=8), dimension( ld_son, nbrow_son ) val_son,
integer, dimension( nsubset_row ) subset_row,
integer, dimension( nsubset_col ) subset_col,
integer nsubset_row,
integer nsubset_col,
integer nsuprow,
integer nsupcol,
integer, dimension( n ) rg2l_row,
integer, dimension( n ) rg2l_col,
logical transpose_asm,
integer, dimension(500) keep,
complex(kind=8), dimension( local_m, nloc) rhs_root,
integer nloc )

Definition at line 604 of file ztype3_root.F.

611 USE zmumps_struc_def, ONLY : zmumps_root_struc
612 IMPLICIT NONE
613 INTEGER N, LOCAL_M, LOCAL_N
614 COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N )
615 INTEGER NPCOL, NPROW, MBLOCK, NBLOCK
616 INTEGER NBCOL_SON, NBROW_SON
617 INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON )
618 INTEGER LD_SON
619 INTEGER NSUPROW, NSUPCOL
620 COMPLEX(kind=8) VAL_SON( LD_SON, NBROW_SON )
621 INTEGER KEEP(500)
622 INTEGER NSUBSET_ROW, NSUBSET_COL
623 INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL )
624 INTEGER RG2L_ROW( N ), RG2L_COL( N )
625 LOGICAL TRANSPOSE_ASM
626 INTEGER NLOC
627 COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC)
628 INTEGER ISUB, JSUB, I, J, IPOS_ROOT, JPOS_ROOT
629 INTEGER ILOC_ROOT, JLOC_ROOT, IGLOB, JGLOB
630 IF (keep(50).EQ.0) THEN
631 DO isub = 1, nsubset_row
632 i = subset_row( isub )
633 iglob = indrow_son( i )
634 ipos_root = rg2l_row( iglob )
635 iloc_root = mblock
636 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
637 & + mod( ipos_root - 1, mblock ) + 1
638 DO jsub = 1, nsubset_col-nsupcol
639 j = subset_col( jsub )
640 jglob = indcol_son( j )
641 jpos_root = rg2l_col( jglob )
642 jloc_root = nblock
643 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
644 & + mod( jpos_root - 1, nblock ) + 1
645 val_root( iloc_root, jloc_root ) =
646 & val_root( iloc_root, jloc_root ) + val_son( j, i )
647 END DO
648 DO jsub = nsubset_col-nsupcol+1, nsubset_col
649 j = subset_col( jsub )
650 jglob = indcol_son( j )
651 jpos_root = jglob - n
652 jloc_root = nblock
653 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
654 & + mod( jpos_root - 1, nblock ) + 1
655 rhs_root(iloc_root, jloc_root) =
656 & rhs_root(iloc_root, jloc_root) + val_son( j, i )
657 ENDDO
658 END DO
659 ELSE
660 IF ( .NOT. transpose_asm ) THEN
661 DO isub = 1, nsubset_row - nsuprow
662 i = subset_row( isub )
663 iglob = indrow_son( i )
664 ipos_root = rg2l_row( iglob )
665 iloc_root = mblock
666 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
667 & + mod( ipos_root - 1, mblock ) + 1
668 DO jsub = 1, nsubset_col -nsupcol
669 j = subset_col( jsub )
670 jglob = indcol_son( j )
671 jpos_root = rg2l_col( jglob )
672 IF (keep(50).NE.0. and. jpos_root .GT. ipos_root) cycle
673 jloc_root = nblock
674 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
675 & + mod( jpos_root - 1, nblock ) + 1
676 val_root( iloc_root, jloc_root ) =
677 & val_root( iloc_root, jloc_root ) + val_son( j, i )
678 END DO
679 END DO
680 DO jsub = nsubset_col -nsupcol+1, nsubset_col
681 j = subset_col( jsub )
682 jglob = indrow_son( j )
683 jpos_root = jglob - n
684 jloc_root = nblock
685 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
686 & + mod( jpos_root - 1, nblock ) + 1
687 DO isub = nsubset_row - nsuprow +1, nsubset_row
688 i = subset_row( isub )
689 iglob = indcol_son( i )
690 ipos_root = rg2l_row(iglob)
691 iloc_root = mblock
692 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
693 & + mod( ipos_root - 1, mblock ) + 1
694 rhs_root(iloc_root, jloc_root) =
695 & rhs_root(iloc_root, jloc_root) + val_son( i, j )
696 END DO
697 END DO
698 ELSE
699 DO isub = 1, nsubset_col-nsupcol
700 i = subset_col( isub )
701 iglob = indrow_son( i )
702 jpos_root = rg2l_col( iglob )
703 jloc_root = nblock
704 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
705 & + mod( jpos_root - 1, nblock ) + 1
706 DO jsub = 1, nsubset_row
707 j = subset_row( jsub )
708 jglob = indcol_son( j )
709 ipos_root = rg2l_row( jglob )
710 iloc_root = mblock
711 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
712 & + mod( ipos_root - 1, mblock ) + 1
713 val_root( iloc_root, jloc_root ) =
714 & val_root( iloc_root, jloc_root ) + val_son( j, i )
715 END DO
716 ENDDO
717 DO isub = nsubset_col-nsupcol+1, nsubset_col
718 i = subset_col( isub )
719 iglob = indrow_son( i )
720 jpos_root = iglob - n
721 jloc_root = nblock
722 & * ( ( jpos_root - 1 ) / ( nblock * npcol ) )
723 & + mod( jpos_root - 1, nblock ) + 1
724 DO jsub = 1, nsubset_row
725 j = subset_row( jsub )
726 jglob = indcol_son( j )
727 ipos_root = rg2l_row( jglob )
728 iloc_root = mblock
729 & * ( ( ipos_root - 1 ) / ( mblock * nprow ) )
730 & + mod( ipos_root - 1, mblock ) + 1
731 rhs_root( iloc_root, jloc_root ) =
732 & rhs_root( iloc_root, jloc_root ) + val_son( j, i )
733 END DO
734 ENDDO
735 END IF
736 END IF
737 RETURN

◆ zmumps_scatter_root()

subroutine zmumps_scatter_root ( integer myid,
integer m,
integer n,
complex(kind=8), dimension( m, n ) aseq,
integer local_m,
integer local_n,
integer mblock,
integer nblock,
complex(kind=8), dimension( local_m, local_n ) apar,
integer master_root,
integer nprow,
integer npcol,
integer comm )

Definition at line 902 of file ztype3_root.F.

909 IMPLICIT NONE
910 INTEGER MYID, MASTER_ROOT, COMM
911 INTEGER M, N
912 INTEGER NPROW, NPCOL
913 INTEGER LOCAL_M, LOCAL_N
914 INTEGER MBLOCK, NBLOCK
915 COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N )
916 COMPLEX(kind=8) ASEQ( M, N )
917 include 'mpif.h'
918 INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL
919 INTEGER IBLOCK, JBLOCK, II, JJ, KK
920 INTEGER IAPAR, JAPAR, IERR, allocok
921 INTEGER :: STATUS(MPI_STATUS_SIZE)
922 COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: WK
923 LOGICAL JUPDATE
924 ALLOCATE(wk( mblock * nblock ), stat=allocok)
925 if(allocok.ne.0) then
926 WRITE(6,*) ' Allocation error of WK in '
927 & // 'routine ZMUMPS_SCATTER_ROOT '
928 CALL mumps_abort()
929 endif
930 iapar = 1
931 japar = 1
932 DO j = 1, n, nblock
933 size_jblock = nblock
934 IF ( j + nblock > n ) THEN
935 size_jblock = n - j + 1
936 END IF
937 jupdate = .false.
938 DO i = 1, m, mblock
939 size_iblock = mblock
940 IF ( i + mblock > m ) THEN
941 size_iblock = m - i + 1
942 END IF
943 iblock = i / mblock
944 jblock = j / nblock
945 irow = mod( iblock, nprow )
946 icol = mod( jblock, npcol )
947 idest = irow * npcol + icol
948 IF ( idest .NE. master_root ) THEN
949 IF ( myid .EQ. master_root ) THEN
950 kk=1
951 DO jj=j,j+size_jblock-1
952 DO ii=i,i+size_iblock-1
953 wk(kk)=aseq(ii,jj)
954 kk=kk+1
955 END DO
956 END DO
957 CALL mpi_ssend( wk, size_iblock*size_jblock,
958 & mpi_double_complex,
959 & idest, 128, comm, ierr )
960 ELSE IF ( myid .EQ. idest ) THEN
961 CALL mpi_recv( wk(1),
962 & size_iblock*size_jblock,
963 & mpi_double_complex,
964 & master_root,128,comm,status,ierr)
965 kk=1
966 DO jj=japar,japar+size_jblock-1
967 DO ii=iapar,iapar+size_iblock-1
968 apar(ii,jj)=wk(kk)
969 kk=kk+1
970 END DO
971 END DO
972 jupdate = .true.
973 iapar = iapar + size_iblock
974 END IF
975 ELSE IF ( myid.EQ. master_root ) THEN
976 apar( iapar:iapar+size_iblock-1,
977 & japar:japar+size_jblock-1 )
978 & = aseq(i:i+size_iblock-1,j:j+size_jblock-1)
979 jupdate = .true.
980 iapar = iapar + size_iblock
981 END IF
982 END DO
983 IF ( jupdate ) THEN
984 iapar = 1
985 japar = japar + size_jblock
986 END IF
987 END DO
988 DEALLOCATE(wk)
989 RETURN

◆ zmumps_set_lda_shift_val_son()

subroutine zmumps_build_and_send_cb_root::zmumps_set_lda_shift_val_son ( integer, dimension(liw), intent(in) iw,
integer, intent(in) liw,
integer, intent(in) ioldps,
integer, intent(out) lda,
integer(8), intent(out) shift_val_son )

Definition at line 572 of file ztype3_root.F.

574 INTEGER, INTENT(IN) :: LIW, IOLDPS
575 INTEGER, INTENT(IN) :: IW(LIW)
576 INTEGER, INTENT(OUT) :: LDA
577 INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON
578 include 'mumps_headers.h'
579 INTEGER :: LCONT, NROW, NPIV, NASS, NELIM
580 lcont = iw(ioldps+keep(ixsz))
581 nrow = iw(ioldps+2+keep(ixsz))
582 npiv = iw(ioldps+3+keep(ixsz))
583 nass = iw(ioldps+4+keep(ixsz))
584 nelim = nass-npiv
585 IF (iw(ioldps+xxs).EQ.s_nolcbnocontig38.OR.
586 & iw(ioldps+xxs).EQ.s_all) THEN
587 shift_val_son = int(npiv,8)
588 lda = lcont + npiv
589 ELSE IF (iw(ioldps+xxs).EQ.s_nolcbcontig38) THEN
590 shift_val_son = int(nrow,8)*int(lcont+npiv-nelim,8)
591 lda = nelim
592 ELSE IF (iw(ioldps+xxs).EQ.s_nolcleaned38) THEN
593 shift_val_son=0_8
594 lda = nelim
595 ELSE
596 WRITE(*,*) myid,
597 & ": internal error in ZMUMPS_SET_LDA_SHIFT_VAL_SON",
598 & iw(ioldps+xxs), "ISON=",ison
599 CALL mumps_abort()
600 ENDIF
601 RETURN