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

Go to the source code of this file.

Functions/Subroutines

subroutine dmumps_solve_node_bwd (inode, n, ipool, lpool, iipool, nbfinf, a, la, iw, liw, w, lwc, nrhs, poswcb, pleftw, posiwcb, rhscomp, lrhscomp, posinrhscomp_bwd, ptricb, ptracb, iwcb, liww, w2, ne_steps, step, frere, fils, ptrist, ptrfac, myleaf_left, info, procnode_steps, deja_send, slavef, comm, myid, bufr, lbufr, lbufr_bytes, keep, keep8, dkeep, rhs_root, lrhs_root, mtype, istep_to_iniv2, tab_pos_in_pere, panel_pos, lpanel_pos, prun_below, to_process, size_to_process, rhs_bounds, lrhs_bounds, do_nbsparse, from_pp, error_was_broadcasted, do_mcast2_termbwd)
recursive subroutine dmumps_backslv_recv_and_treat (bloq, flag, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, iwcb, liww, posiwcb, w, lwc, poswcb, iipool, nbfinf, ptricb, ptracb, info, ipool, lpool, panel_pos, lpanel_pos, step, frere, fils, procnode_steps, pleftw, keep, keep8, dkeep, ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left, nrhs, mtype, rhscomp, lrhscomp, posinrhscomp_bwd, prun_below, to_process, size_to_process, from_pp)
recursive subroutine dmumps_backslv_traiter_message (msgtag, msgsou, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, iwcb, liww, posiwcb, w, lwc, poswcb, iipool, nbfinf, ptricb, ptracb, info, ipool, lpool, panel_pos, lpanel_pos, step, frere, fils, procnode_steps, pleftw, keep, keep8, dkeep, ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left, nrhs, mtype, rhscomp, lrhscomp, posinrhscomp_bwd, prun_below, to_process, size_to_process, from_pp)
subroutine dmumps_build_panel_pos (panel_size, panel_pos, len_panel_pos, indices, npiv, npanels, nfront_or_nass, nbentries_allpanels)

Function/Subroutine Documentation

◆ dmumps_backslv_recv_and_treat()

recursive subroutine dmumps_backslv_recv_and_treat ( logical bloq,
logical flag,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer myid,
integer slavef,
integer comm,
integer n,
integer, dimension( liww ) iwcb,
integer liww,
integer posiwcb,
double precision, dimension( lwc ) w,
integer(8), intent(in) lwc,
integer(8) poswcb,
integer iipool,
integer nbfinf,
integer, dimension(keep(28)) ptricb,
integer(8), dimension(keep(28)) ptracb,
integer, dimension(80) info,
integer, dimension( lpool ) ipool,
integer lpool,
integer, dimension( lpanel_pos ) panel_pos,
integer lpanel_pos,
integer, dimension( n ) step,
integer, dimension( keep(28) ) frere,
integer, dimension( n ) fils,
integer, dimension( keep(28) ) procnode_steps,
integer(8) pleftw,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230), intent(inout) dkeep,
integer, dimension(keep(28)) ptrist,
integer (8), dimension(keep(28)) ptrfac,
integer, dimension( liw ) iw,
integer liw,
double precision, dimension( la ) a,
integer(8) la,
double precision, dimension( keep(133) ) w2,
integer myleaf_left,
integer nrhs,
integer mtype,
double precision, dimension(lrhscomp,nrhs) rhscomp,
integer lrhscomp,
integer, dimension(n) posinrhscomp_bwd,
logical, intent(in) prun_below,
logical, dimension(size_to_process) to_process,
integer size_to_process,
logical, intent(in) from_pp )

Definition at line 961 of file dsol_bwd_aux.F.

977 IMPLICIT NONE
978 LOGICAL BLOQ, FLAG
979 INTEGER LBUFR, LBUFR_BYTES
980 INTEGER BUFR( LBUFR )
981 INTEGER MYID, SLAVEF, COMM
982 INTEGER N, LIWW
983 INTEGER IWCB( LIWW )
984 INTEGER(8), intent(in) :: LWC
985 DOUBLE PRECISION W( LWC )
986 INTEGER POSIWCB
987 INTEGER IIPOOL, LPOOL
988 INTEGER IPOOL( LPOOL )
989 INTEGER LPANEL_POS
990 INTEGER PANEL_POS( LPANEL_POS )
991 INTEGER NBFINF, INFO(80), KEEP(500)
992 INTEGER(8) :: POSWCB, PLEFTW
993 INTEGER(8) KEEP8(150)
994 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
995 INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) )
996 INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N )
997 INTEGER(8) :: PTRACB(KEEP(28))
998 INTEGER LIW
999 INTEGER(8) :: LA
1000 INTEGER PTRIST(KEEP(28)), IW( LIW )
1001 INTEGER (8) :: PTRFAC(KEEP(28))
1002 DOUBLE PRECISION A( LA ), W2( KEEP(133) )
1003 INTEGER NRHS
1004 INTEGER MYLEAF_LEFT, MTYPE
1005 INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N)
1006 DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS)
1007 LOGICAL, INTENT(IN) :: PRUN_BELOW
1008 INTEGER SIZE_TO_PROCESS
1009 LOGICAL TO_PROCESS(SIZE_TO_PROCESS)
1010 LOGICAL, intent(in) :: FROM_PP
1011 include 'mpif.h'
1012 include 'mumps_tags.h'
1013 INTEGER MSGSOU, MSGTAG, MSGLEN
1014 INTEGER :: STATUS(MPI_STATUS_SIZE)
1015 INTEGER :: IERR
1016 flag = .false.
1017 IF ( bloq ) THEN
1018 CALL mpi_probe( mpi_any_source, mpi_any_tag,
1019 & comm, status, ierr )
1020 flag = .true.
1021 ELSE
1022 CALL mpi_iprobe( mpi_any_source, mpi_any_tag, comm,
1023 & flag, status, ierr )
1024 END IF
1025 IF (flag) THEN
1026 keep(266)=keep(266)-1
1027 msgsou=status(mpi_source)
1028 msgtag=status(mpi_tag)
1029 CALL mpi_get_count( status, mpi_packed, msglen, ierr )
1030 IF ( msglen .GT. lbufr_bytes ) THEN
1031 info(1) = -20
1032 info(2) = msglen
1033 IF (nbfinf .NE. 0) THEN
1034 CALL dmumps_bdc_error( myid, slavef, comm, keep )
1035 ENDIF
1036 ELSE
1037 CALL mpi_recv(bufr, lbufr_bytes, mpi_packed, msgsou,
1038 & msgtag, comm, status, ierr)
1039 CALL dmumps_backslv_traiter_message( msgtag, msgsou,
1040 & bufr, lbufr, lbufr_bytes,
1041 & myid, slavef, comm,
1042 & n, iwcb, liww, posiwcb,
1043 & w, lwc, poswcb,
1044 & iipool, nbfinf, ptricb, ptracb, info,
1045 & ipool, lpool, panel_pos, lpanel_pos, step,
1046 & frere, fils, procnode_steps, pleftw,
1047 & keep, keep8, dkeep,
1048 & ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left,
1049 & nrhs, mtype,
1050 & rhscomp, lrhscomp, posinrhscomp_bwd,
1051 & prun_below, to_process, size_to_process
1052 & , from_pp
1053 & )
1054 END IF
1055 END IF
1056 RETURN
dmumps_bdc_error
subroutine dmumps_bdc_error(myid, slavef, comm, keep)
Definition dbcast_int.F:38
dmumps_backslv_traiter_message
recursive subroutine dmumps_backslv_traiter_message(msgtag, msgsou, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, iwcb, liww, posiwcb, w, lwc, poswcb, iipool, nbfinf, ptricb, ptracb, info, ipool, lpool, panel_pos, lpanel_pos, step, frere, fils, procnode_steps, pleftw, keep, keep8, dkeep, ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left, nrhs, mtype, rhscomp, lrhscomp, posinrhscomp_bwd, prun_below, to_process, size_to_process, from_pp)
Definition dsol_bwd_aux.F:1074
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_get_count
subroutine mpi_get_count(status, datatype, cnt, ierr)
Definition mpi.f:296
mpi_probe
subroutine mpi_probe(source, tag, comm, status, ierr)
Definition mpi.f:449

◆ dmumps_backslv_traiter_message()

recursive subroutine dmumps_backslv_traiter_message ( integer msgtag,
integer msgsou,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer myid,
integer slavef,
integer comm,
integer n,
integer, dimension( liww ) iwcb,
integer liww,
integer posiwcb,
double precision, dimension( lwc ) w,
integer(8), intent(in) lwc,
integer(8) poswcb,
integer iipool,
integer nbfinf,
integer, dimension(keep(28)) ptricb,
integer(8), dimension(keep(28)) ptracb,
integer, dimension(80) info,
integer, dimension( lpool ) ipool,
integer lpool,
integer, dimension( lpanel_pos ) panel_pos,
integer lpanel_pos,
integer, dimension( n ) step,
integer, dimension(keep(28)) frere,
integer, dimension( n ) fils,
integer, dimension(keep(28)) procnode_steps,
integer(8) pleftw,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230), intent(inout) dkeep,
integer, dimension( keep(28) ) ptrist,
integer(8), dimension(keep(28)) ptrfac,
integer, dimension( liw ) iw,
integer liw,
double precision, dimension( la ) a,
integer(8) la,
double precision, dimension( keep(133) ) w2,
integer myleaf_left,
integer nrhs,
integer mtype,
double precision, dimension(lrhscomp,nrhs) rhscomp,
integer lrhscomp,
integer, dimension(n) posinrhscomp_bwd,
logical, intent(in) prun_below,
logical, dimension(size_to_process) to_process,
integer size_to_process,
logical, intent(in) from_pp )

Definition at line 1058 of file dsol_bwd_aux.F.

1074 USE dmumps_ooc
1075 USE dmumps_sol_lr, ONLY: dmumps_sol_slave_lr_u,
1076 & dmumps_sol_bwd_lr_su
1077 USE dmumps_buf
1078 IMPLICIT NONE
1079 INTEGER MSGTAG, MSGSOU
1080 INTEGER LBUFR, LBUFR_BYTES
1081 INTEGER BUFR( LBUFR )
1082 INTEGER MYID, SLAVEF, COMM
1083 INTEGER N, LIWW
1084 INTEGER IWCB( LIWW )
1085 INTEGER(8), intent(in) :: LWC
1086 DOUBLE PRECISION W( LWC )
1087 INTEGER POSIWCB
1088 INTEGER IIPOOL, LPOOL, LPANEL_POS
1089 INTEGER IPOOL( LPOOL )
1090 INTEGER PANEL_POS( LPANEL_POS )
1091 INTEGER NBFINF, INFO(80), KEEP(500)
1092 INTEGER(8) :: POSWCB, PLEFTW
1093 INTEGER(8) KEEP8(150)
1094 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
1095 INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N )
1096 INTEGER(8) :: PTRACB(KEEP(28))
1097 INTEGER FRERE(KEEP(28))
1098 INTEGER PROCNODE_STEPS(KEEP(28))
1099 INTEGER LIW
1100 INTEGER(8) :: LA
1101 INTEGER IW( LIW ), PTRIST( KEEP(28) )
1102 INTEGER(8) :: PTRFAC(KEEP(28))
1103 DOUBLE PRECISION A( LA ), W2( KEEP(133) )
1104 INTEGER NRHS
1105 INTEGER MYLEAF_LEFT, MTYPE
1106 INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N)
1107 DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS)
1108 LOGICAL, INTENT(IN) :: PRUN_BELOW
1109 INTEGER SIZE_TO_PROCESS
1110 LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN
1111 LOGICAL, intent(in) :: FROM_PP
1112 include 'mpif.h'
1113 include 'mumps_tags.h'
1114 INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1)
1115 INTEGER :: LIELL, K
1116 INTEGER(8) :: APOS, IST
1117 INTEGER NPIV, NROW_L, IPOS, NROW_RECU
1118 INTEGER(8) :: IFR8
1119 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA
1120 INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS,
1121 & IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL
1122 INTEGER JBDEB, JBFIN, NRHS_B, allocok
1123 INTEGER(8) :: P_UPDATE, P_SOL_MAS
1124 INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE
1125 LOGICAL FLAG
1126 DOUBLE PRECISION ZERO, ALPHA, ONE
1127 parameter(zero=0.0d0, one = 1.0d0, alpha=-1.0d0)
1128 include 'mumps_headers.h'
1129 INTEGER POOL_FIRST_POS, TMP
1130 LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND
1131 INTEGER :: NCB
1132 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS
1133 INTEGER(8) :: PTWCB_PANEL
1134 INTEGER(8) :: PTWCB, PPIV_COURANT
1135 INTEGER LDAJ, NBJ, LIWFAC,
1136 & NBJLAST, NPIV_LAST, PANEL_SIZE,
1137 & NCB_PANEL, TYPEF
1138 LOGICAL TWOBYTWO
1139 INTEGER BEG_PANEL
1140 INTEGER IPANEL, NPANELS
1141 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR
1142 LOGICAL MUST_BE_PERMUTED
1143 LOGICAL COMPRESS_PANEL, LR_ACTIVATED
1144 LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR
1145 LOGICAL :: ALLOW_OTHERS_TO_LEAVE
1146 LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR
1147 INTEGER, EXTERNAL :: MUMPS_PROCNODE
1148 ALLOCATE(deja_send( 0:slavef-1 ), stat=allocok)
1149 if(allocok.ne.0) then
1150 info(1)=-13
1151 info(2)=slavef
1152 WRITE(6,*) myid,' Allocation error of DEJA_SEND '
1153 & //'in bwd solve COMPSO'
1154 GOTO 260
1155 END IF
1156 dummy(1)=0
1157 IF (msgtag .EQ. termbwd) THEN
1158 nbfinf = nbfinf - 1
1159 ELSE IF (msgtag .EQ. noeud) THEN
1160 position = 0
1161 CALL mpi_unpack(bufr, lbufr_bytes, position,
1162 & inode, 1, mpi_integer,
1163 & comm, ierr)
1164 CALL mpi_unpack( bufr, lbufr_bytes, position,
1165 & jbdeb, 1, mpi_integer, comm, ierr )
1166 CALL mpi_unpack( bufr, lbufr_bytes, position,
1167 & jbfin, 1, mpi_integer, comm, ierr )
1168 CALL mpi_unpack(bufr, lbufr_bytes, position,
1169 & long, 1, mpi_integer,
1170 & comm, ierr)
1171 nrhs_b = jbfin-jbdeb+1
1172 IF ( posiwcb - long .LT. 0
1173 & .OR. poswcb - pleftw + 1_8 .LT. long ) THEN
1174 CALL dmumps_compso(n, keep(28), iwcb,
1175 & liww, w, lwc,
1176 & poswcb, posiwcb, ptricb, ptracb)
1177 IF (posiwcb - long .LT. 0) THEN
1178 info(1)=-14
1179 info(2)=-posiwcb + long
1180 WRITE(6,*) myid,' Internal error 1 in bwd solve COMPSO'
1181 GOTO 260
1182 END IF
1183 IF ( poswcb - pleftw + 1_8 .LT. long ) THEN
1184 info(1) = -11
1185 CALL mumps_set_ierror(long + pleftw - poswcb - 1_8,
1186 & info(2))
1187 WRITE(6,*) myid,' Internal error 2 in bwd solve COMPSO'
1188 GOTO 260
1189 END IF
1190 ENDIF
1191 posiwcb = posiwcb - long
1192 poswcb = poswcb - long
1193 IF (long .GT. 0) THEN
1194 CALL mpi_unpack(bufr, lbufr_bytes, position,
1195 & iwcb(posiwcb + 1),
1196 & long, mpi_integer, comm, ierr)
1197 DO k=jbdeb,jbfin
1198 CALL mpi_unpack(bufr, lbufr_bytes, position,
1199 & w(poswcb + 1), long,
1200 & mpi_double_precision, comm, ierr)
1201 DO jj=0, long-1
1202 iposinrhscomp = abs( posinrhscomp_bwd( iwcb(
1203 & posiwcb+1+jj ) ) )
1204 IF ( (iposinrhscomp.EQ.0) .OR.
1205 & ( iposinrhscomp.GT.n ) ) cycle
1206 rhscomp(iposinrhscomp,k) = w(poswcb+1+jj)
1207 ENDDO
1208 ENDDO
1209 posiwcb = posiwcb + long
1210 poswcb = poswcb + long
1211 ENDIF
1212 pool_first_pos = iipool
1213 IF ( prun_below ) THEN
1214 IF (.NOT.to_process(step(inode)))
1215 & GOTO 1010
1216 ENDIF
1217 ipool( iipool ) = inode
1218 iipool = iipool + 1
1219 1010 CONTINUE
1220 IF = frere( step(inode) )
1221 DO WHILE ( IF .GT. 0 )
1222 IF ( mumps_procnode(procnode_steps(step(if)),
1223 & keep(199)) .eq. myid ) THEN
1224 IF ( prun_below ) THEN
1225 IF (.NOT.to_process(step(if))) THEN
1226 IF = frere(step(if))
1227 cycle
1228 ENDIF
1229 ENDIF
1230 ipool( iipool ) = IF
1231 iipool = iipool + 1
1232 END IF
1233 IF = frere( step( IF ) )
1234 END DO
1235 DO i=1,(iipool-pool_first_pos)/2
1236 tmp=ipool(pool_first_pos+i-1)
1237 ipool(pool_first_pos+i-1)=ipool(iipool-i)
1238 ipool(iipool-i)=tmp
1239 ENDDO
1240 ELSE IF ( msgtag .EQ. backslv_master2slave ) THEN
1241 position = 0
1242 CALL mpi_unpack( bufr, lbufr_bytes, position,
1243 & inode, 1, mpi_integer, comm, ierr )
1244 CALL mpi_unpack( bufr, lbufr_bytes, position,
1245 & nrow_recu, 1, mpi_integer, comm, ierr )
1246 CALL mpi_unpack( bufr, lbufr_bytes, position,
1247 & jbdeb, 1, mpi_integer, comm, ierr )
1248 CALL mpi_unpack( bufr, lbufr_bytes, position,
1249 & jbfin, 1, mpi_integer, comm, ierr )
1250 nrhs_b = jbfin-jbdeb+1
1251 lr_activated = (iw(ptrist(step(inode))+xxlr).GT.0)
1252 compress_panel = (iw(ptrist(step(inode))+xxlr).GE.2)
1253 oocwrite_compatible_with_blr =
1254 & ( .NOT.lr_activated.OR.(.NOT.compress_panel).OR.
1255 & (keep(485).EQ.0)
1256 & )
1257 ipos = ptrist( step(inode) ) + keep(ixsz)
1258 npiv = - iw( ipos )
1259 nrow_l = iw( ipos + 1 )
1260 IF ( nrow_l .NE. nrow_recu ) THEN
1261 WRITE(*,*) 'Error1 : NROW L/RECU=',nrow_l, nrow_recu
1262 CALL mumps_abort()
1263 END IF
1264 long = nrow_l + npiv
1265 IF ( poswcb - int(long,8)*int(nrhs_b,8) .LT. pleftw - 1_8 ) THEN
1266 CALL dmumps_compso( n, keep(28), iwcb,
1267 & liww, w, lwc,
1268 & poswcb, posiwcb, ptricb, ptracb)
1269 IF ( poswcb - long*nrhs_b .LT. pleftw - 1_8 ) THEN
1270 info(1) = -11
1271 CALL mumps_set_ierror(long * nrhs_b- poswcb,info(2))
1272 WRITE(6,*) myid,' Internal error 3 in bwd solve COMPSO'
1273 GOTO 260
1274 END IF
1275 END IF
1276 p_update = pleftw
1277 p_sol_mas = pleftw + int(npiv,8) * int(nrhs_b,8)
1278 pleftw = p_sol_mas + int(nrow_l,8) * int(nrhs_b,8)
1279 DO k=jbdeb, jbfin
1280 CALL mpi_unpack( bufr, lbufr_bytes, position,
1281 & w( p_sol_mas+(k-jbdeb)*nrow_l),nrow_l,
1282 & mpi_double_precision,
1283 & comm, ierr )
1284 ENDDO
1285 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr) THEN
1286 CALL dmumps_solve_get_ooc_node(
1287 & inode,ptrfac,keep,a,la,step,
1288 & keep8,n,must_be_permuted,ierr)
1289 IF(ierr.LT.0)THEN
1290 info(1)=ierr
1291 info(2)=0
1292 GOTO 260
1293 ENDIF
1294 ENDIF
1295 apos = ptrfac( step(inode))
1296 IF ( iw(ptrist(step(inode))+xxlr) .GE. 2 .AND.
1297 & keep(485) .EQ. 1 ) THEN
1298 iwhdlr = iw(ptrist(step(inode))+xxf)
1299 mtype_slave = 0
1300 w(p_update:p_update+npiv*nrhs_b-1)=zero
1301 CALL dmumps_sol_slave_lr_u(inode, iwhdlr, -9999,
1302 & w, lwc,
1303 & nrow_l, npiv,
1304 & p_sol_mas, p_update,
1305 & jbdeb, jbfin,
1306 & mtype_slave, keep, keep8,
1307 & info(1), info(2) )
1308 ELSE
1309 IF (keep(201) .EQ. 1.AND.oocwrite_compatible_with_blr)
1310 & THEN
1311 mtype_slave = 1
1312 lda_slave = nrow_l
1313 ELSE
1314 mtype_slave = 0
1315 lda_slave = npiv
1316 ENDIF
1317 CALL dmumps_solve_gemm_update(
1318 & a, la, apos, nrow_l,
1319 & lda_slave,
1320 & npiv,
1321 & nrhs_b, w, lwc,
1322 & p_sol_mas, nrow_l,
1323 & p_update, npiv,
1324 & mtype_slave, keep, zero)
1325 ENDIF
1326 IF (keep(201) .EQ. 1.AND.oocwrite_compatible_with_blr)
1327 & THEN
1328 CALL dmumps_free_factors_for_solve(inode,ptrfac,keep(28),
1329 & a,la,.true.,ierr)
1330 IF(ierr.LT.0)THEN
1331 info(1)=ierr
1332 info(2)=0
1333 GOTO 260
1334 ENDIF
1335 ENDIF
1336 pleftw = pleftw - int(nrow_l,8) * int(nrhs_b,8)
1337 100 CONTINUE
1338 CALL dmumps_buf_send_backvec( nrhs_b, inode,
1339 & w(p_update),
1340 & npiv, npiv,
1341 & msgsou,
1342 & backslv_updaterhs,
1343 & jbdeb, jbfin,
1344 & keep, comm, ierr )
1345 IF ( ierr .EQ. -1 ) THEN
1346 CALL dmumps_backslv_recv_and_treat(
1347 & .false., flag,
1348 & bufr, lbufr, lbufr_bytes,
1349 & myid, slavef, comm,
1350 & n, iwcb, liww, posiwcb,
1351 & w, lwc, poswcb,
1352 & iipool, nbfinf, ptricb, ptracb, info,
1353 & ipool, lpool, panel_pos, lpanel_pos, step,
1354 & frere, fils, procnode_steps, pleftw,
1355 & keep, keep8, dkeep,
1356 & ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left,
1357 & nrhs, mtype,
1358 & rhscomp, lrhscomp, posinrhscomp_bwd,
1359 & prun_below, to_process, size_to_process
1360 & , from_pp
1361 & )
1362 IF ( info( 1 ) .LT. 0 ) GOTO 270
1363 GOTO 100
1364 ELSE IF ( ierr .EQ. -2 ) THEN
1365 info( 1 ) = -17
1366 info( 2 ) = nrhs_b * npiv * keep(35) + 4 * keep(34)
1367 GOTO 260
1368 ELSE IF ( ierr .EQ. -3 ) THEN
1369 info( 1 ) = -20
1370 info( 2 ) = nrhs_b * npiv * keep(35) + 4 * keep(34)
1371 GOTO 260
1372 END IF
1373 pleftw = pleftw - npiv * nrhs_b
1374 ELSE IF ( msgtag .EQ. backslv_updaterhs ) THEN
1375 position = 0
1376 CALL mpi_unpack( bufr, lbufr_bytes, position,
1377 & inode, 1, mpi_integer, comm, ierr )
1378 lr_activated = (iw(ptrist(step(inode))+xxlr).GT.0)
1379 compress_panel = (iw(ptrist(step(inode))+xxlr).GE.2)
1380 oocwrite_compatible_with_blr =
1381 & (.NOT.lr_activated.OR.(.NOT.compress_panel).OR.
1382 & (keep(485).EQ.0)
1383 & )
1384 ipos = ptrist(step(inode)) + 2 + keep(ixsz)
1385 liell = iw(ipos-2)+iw(ipos+1)
1386 CALL mpi_unpack( bufr, lbufr_bytes, position,
1387 & npiv, 1, mpi_integer, comm, ierr )
1388 CALL mpi_unpack( bufr, lbufr_bytes, position,
1389 & jbdeb, 1, mpi_integer, comm, ierr )
1390 CALL mpi_unpack( bufr, lbufr_bytes, position,
1391 & jbfin, 1, mpi_integer, comm, ierr )
1392 nrhs_b = jbfin-jbdeb+1
1393 nelim = iw(ipos-1)
1394 ipos = ipos + 1
1395 npiv = iw(ipos)
1396 ipos = ipos + 1
1397 nslaves = iw( ipos + 1 )
1398 ipos = ipos + 1 + nslaves
1399 inodepos = ptrist(step(inode)) + keep(ixsz) + 4
1400 IF ( keep(50) .eq. 0 ) THEN
1401 lda = liell
1402 ELSE
1403 lda = npiv
1404 ENDIF
1405 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
1406 j1 = ipos + liell + 1
1407 j2 = ipos + npiv + liell
1408 ELSE
1409 j1 = ipos + 1
1410 j2 = ipos + npiv
1411 ENDIF
1412 iposinrhscomp = posinrhscomp_bwd(iw(j1))
1413 DO k=jbdeb, jbfin
1414 CALL mpi_unpack( bufr, lbufr_bytes, position,
1415 & w2, npiv, mpi_double_precision,
1416 & comm, ierr )
1417 i = 1
1418 IF ( (keep(253).NE.0) .AND.
1419 & (iw(ptrist(step(inode))+xxs).EQ.c_fini+nslaves)
1420 & ) THEN
1421 DO jj = j1,j2
1422 rhscomp(iposinrhscomp+jj-j1,k) = w2(i)
1423 i = i+1
1424 ENDDO
1425 ELSE
1426 DO jj = j1,j2
1427 rhscomp(iposinrhscomp+jj-j1,k) =
1428 & rhscomp(iposinrhscomp+jj-j1,k) + w2(i)
1429 i = i+1
1430 ENDDO
1431 ENDIF
1432 ENDDO
1433 iw(ptrist(step(inode))+xxs) =
1434 & iw(ptrist(step(inode))+xxs) - 1
1435 IF ( iw(ptrist(step(inode))+xxs).EQ.c_fini ) THEN
1436 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr)
1437 & THEN
1438 CALL dmumps_solve_get_ooc_node(
1439 & inode,ptrfac,keep,a,la,step,
1440 & keep8,n,must_be_permuted,ierr)
1441 IF(ierr.LT.0)THEN
1442 info(1)=ierr
1443 info(2)=0
1444 GOTO 260
1445 ENDIF
1446 IF (keep(201).EQ.1 .AND. keep(50).NE.1) THEN
1447 CALL dmumps_ooc_pp_check_perm_freed(
1448 & iw(ipos+1+2*liell),
1449 & must_be_permuted )
1450 ENDIF
1451 ENDIF
1452 apos = ptrfac(iw(inodepos))
1453 IF (keep(201).EQ.1.AND.oocwrite_compatible_with_blr)
1454 & THEN
1455 liwfac = iw(ptrist(step(inode))+xxi)
1456 typef = typef_l
1457 nrow_l = npiv+nelim
1458 panel_size = dmumps_ooc_panel_size(nrow_l)
1459 IF (panel_size.LT.0) THEN
1460 WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=',
1461 & panel_size
1462 CALL mumps_abort()
1463 ENDIF
1464 ENDIF
1465 IF ( posiwcb - 2 .LT. 0 .or.
1466 & poswcb-int(liell,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
1467 CALL dmumps_compso( n, keep(28), iwcb, liww, w, lwc,
1468 & poswcb, posiwcb, ptricb, ptracb )
1469 IF ( poswcb-int(liell,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
1470 info( 1 ) = -11
1471 CALL mumps_set_ierror( int(liell,8)*int(nrhs_b,8)-
1472 & poswcb-pleftw+1_8,
1473 & info(2) )
1474 GOTO 260
1475 END IF
1476 IF ( posiwcb - 2 .LT. 0 ) THEN
1477 info( 1 ) = -14
1478 info( 2 ) = 2 - posiwcb
1479 GO TO 260
1480 END IF
1481 END IF
1482 posiwcb = posiwcb - 2
1483 poswcb = poswcb - int(liell,8)*int(nrhs_b,8)
1484 ptricb(step( inode )) = posiwcb + 1
1485 ptracb(step( inode )) = poswcb + 1_8
1486 iwcb( ptricb(step( inode )) ) = liell*nrhs_b
1487 iwcb( ptricb(step( inode )) + 1 ) = 1
1488 ipos = ptrist(step(inode)) + keep(ixsz) + 5 + nslaves
1489 IF ( mtype.EQ.1 .AND. keep(50).EQ.0 ) THEN
1490 posindices = ipos + liell + 1
1491 ELSE
1492 posindices = ipos + 1
1493 END IF
1494 ptwcb = ptracb(step( inode ))
1495 iposinrhscomp = posinrhscomp_bwd(iw(j1))
1496 ifr8 = ptracb(step( inode ))
1497 ifr8 = ptwcb + int(npiv - 1,8)
1498 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
1499 j1 = ipos + liell + npiv + 1
1500 j2 = ipos + 2 * liell
1501 ELSE
1502 j1 = ipos + npiv + 1
1503 j2 = ipos + liell
1504 END IF
1505 CALL dmumps_sol_bwd_gthr( jbdeb, jbfin, j1, j2,
1506 & rhscomp, nrhs, lrhscomp,
1507 & w(ptwcb), liell, npiv+1,
1508 & iw, liw, keep, n, posinrhscomp_bwd )
1509 ifr8 = ifr8 + int(j2-keep(253)-j1+1,8)
1510 IF ( keep(201).EQ.1 .AND. oocwrite_compatible_with_blr .AND.
1511 & (( nelim .GT. 0 ).OR. (mtype.NE.1 ))) THEN
1512 j = npiv / panel_size
1513 twobytwo = keep(50).EQ.2 .AND. keep(105).GT.0
1514 IF (twobytwo) THEN
1515 CALL dmumps_build_panel_pos(panel_size, panel_pos, lpanel_pos,
1516 & iw(ipos+1+liell), npiv, npanels, nrow_l,
1517 & nbentries_allpanels)
1518 ELSE
1519 IF (npiv.EQ.j*panel_size) THEN
1520 npiv_last = npiv
1521 nbjlast = panel_size
1522 npanels = j
1523 ELSE
1524 npiv_last = (j+1)* panel_size
1525 nbjlast = npiv-j*panel_size
1526 npanels = j+1
1527 ENDIF
1528 nbentries_allpanels =
1529 & int(nrow_l,8) * int(npiv,8)
1530 & - int( ( j * ( j - 1 ) ) /2,8 )
1531 & * int(panel_size,8) * int(panel_size,8)
1532 & - int(j,8)
1533 & * int(mod(npiv, panel_size),8)
1534 & * int(panel_size,8)
1535 jj=npiv_last
1536 ENDIF
1537 aposdeb = apos + nbentries_allpanels
1538 DO ipanel = npanels, 1, -1
1539 IF (twobytwo) THEN
1540 nbj = panel_pos(ipanel+1)-panel_pos(ipanel)
1541 beg_panel = panel_pos(ipanel)
1542 ELSE
1543 IF (jj.EQ.npiv_last) THEN
1544 nbj = nbjlast
1545 ELSE
1546 nbj = panel_size
1547 ENDIF
1548 beg_panel = jj- panel_size+1
1549 ENDIF
1550 ldaj = nrow_l-beg_panel+1
1551 aposdeb = aposdeb - int(nbj,8)*int(ldaj,8)
1552 ptwcb = ptracb(step(inode))
1553 ptwcb_panel = ptracb(step(inode)) + int(beg_panel - 1,8)
1554 iposinrhscomp_panel = iposinrhscomp + beg_panel - 1
1555 ncb_panel = ldaj - nbj
1556 ncb = nrow_l - npiv
1557 IF (keep(50).NE.1 .AND.must_be_permuted) THEN
1558 CALL dmumps_get_ooc_perm_ptr(typef, tmp_nbpanels,
1559 & i_pivrptr, i_pivr, ipos + 1 + 2 * liell, iw, liw)
1560 CALL dmumps_permute_panel(
1561 & iw(i_pivr + iw(i_pivrptr+ipanel-1)-iw(i_pivrptr)),
1562 & npiv-iw(i_pivrptr+ipanel-1)+1,
1563 & iw(i_pivrptr+ipanel-1)-1,
1564 & a(aposdeb),
1565 & ldaj, nbj, beg_panel-1)
1566 ENDIF
1567#if defined(MUMPS_USE_BLAS2)
1568 IF ( nrhs_b == 1 ) THEN
1569 IF (ncb_panel.NE.0) THEN
1570 IF (ncb_panel - ncb.NE. 0) THEN
1571 CALL dgemv( 'T', ncb_panel-ncb, nbj, alpha,
1572 & a( aposdeb + int(nbj,8) ), ldaj,
1573 & rhscomp(iposinrhscomp_panel+nbj,jbdeb),
1574 & 1, one,
1575 & rhscomp(iposinrhscomp_panel,jbdeb), 1 )
1576 ENDIF
1577 IF (ncb .NE. 0) THEN
1578 CALL dgemv( 'T', ncb, nbj, alpha,
1579 & a( aposdeb + int(ldaj-ncb,8) ), ldaj,
1580 & w( ptwcb + int(npiv,8) ),
1581 & 1, one,
1582 & rhscomp(iposinrhscomp_panel,jbdeb), 1 )
1583 ENDIF
1584 ENDIF
1585 IF (mtype.NE.1) THEN
1586 CALL dtrsv('L','T','U', nbj, a(aposdeb), ldaj,
1587 & rhscomp(iposinrhscomp_panel,jbdeb), 1)
1588 ELSE
1589 CALL dtrsv('L','T','N', nbj, a(aposdeb), ldaj,
1590 & rhscomp(iposinrhscomp_panel,jbdeb), 1)
1591 ENDIF
1592 ELSE
1593#endif
1594 IF (ncb_panel.NE.0) THEN
1595 IF (ncb_panel - ncb .NE. 0) THEN
1596 CALL dgemm( 'T', 'N', nbj, nrhs_b,
1597 & ncb_panel-ncb, alpha,
1598 & a(aposdeb +int(nbj,8)), ldaj,
1599 & rhscomp(iposinrhscomp_panel+nbj,jbdeb), lrhscomp,
1600 & one, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
1601 ENDIF
1602 IF (ncb .NE. 0) THEN
1603 CALL dgemm( 'T', 'N', nbj, nrhs_b, ncb, alpha,
1604 & a(aposdeb +int(ldaj-ncb,8)), ldaj,
1605 & w( ptwcb+int(npiv,8) ), liell,
1606 & one, rhscomp(iposinrhscomp_panel,jbdeb),lrhscomp)
1607 ENDIF
1608 ENDIF
1609 IF (mtype.NE.1) THEN
1610 CALL dtrsm('L','L','T','U',nbj, nrhs_b, one,
1611 & a(aposdeb),
1612 & ldaj, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
1613 ELSE
1614 CALL dtrsm('L','L','T','N',nbj, nrhs_b, one,
1615 & a(aposdeb),
1616 & ldaj, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
1617 ENDIF
1618#if defined(MUMPS_USE_BLAS2)
1619 ENDIF
1620#endif
1621 IF (.NOT. twobytwo) jj=beg_panel-1
1622 ENDDO
1623 GOTO 1234
1624 ENDIF
1625 IF ( iw(ptrist(step(inode))+xxlr) .GE. 2
1626 & .AND. keep(485) .EQ. 1 ) THEN
1627 iwhdlr = iw(ptrist(step(inode))+xxf)
1628 CALL dmumps_sol_bwd_lr_su (
1629 & inode, iwhdlr, npiv, nslaves,
1630 & liell, w, lwc, nrhs_b, ptracb(step(inode)),
1631 & rhscomp, lrhscomp, nrhs,
1632 & iposinrhscomp, jbdeb,
1633 & mtype, keep, keep8,
1634 & info(1), info(2) )
1635 ELSE
1636 IF (nelim .GT.0) THEN
1637 IF ( keep(50) .eq. 0 ) THEN
1638 ist = apos + int(npiv,8) * int(liell,8)
1639 ELSE
1640 IF( keep(459) .GT. 1) THEN
1641 CALL mumps_geti8(ist, iw(ptrist(step(inode))+xxr))
1642 ist = apos + ist - int(npiv,8) * int(nelim,8)
1643 ELSE
1644 ist = apos + int(npiv,8) * int(npiv,8)
1645 ENDIF
1646 END IF
1647#if defined(MUMPS_USE_BLAS2)
1648 IF ( nrhs_b == 1 ) THEN
1649 CALL dgemv( 'N', npiv, nelim, alpha, a( ist ), npiv,
1650 & w( npiv + ptracb(step(inode)) ),
1651 & 1, one,
1652 & rhscomp(iposinrhscomp,jbdeb), 1 )
1653 ELSE
1654#endif
1655 CALL dgemm( 'n', 'n', NPIV, NRHS_B, NELIM, ALPHA,
1656 & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))), LIELL,
1657 & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP)
1658#if defined(MUMPS_USE_BLAS2)
1659 END IF
1660#endif
1661 ENDIF
1662 PPIV_COURANT = int(JBDEB-1,8)*int(LRHSCOMP,8)
1663 & + int(IPOSINRHSCOMP,8)
1664.GT..AND..NE. IF (KEEP(459)1 KEEP(50)0) THEN
1665 CALL DMUMPS_SOLVE_BWD_PANELS( A, LA, APOS,
1666 & NPIV, IW(IPOS+1+LIELL),
1667 & NRHS_B, RHSCOMP(1,1), KEEP8(25), LRHSCOMP, PPIV_COURANT,
1668 & MTYPE, KEEP )
1669 ELSE
1670 CALL DMUMPS_SOLVE_BWD_TRSOLVE( A, LA, APOS,
1671 & NPIV, LDA,
1672 & NRHS_B, RHSCOMP(1,1), KEEP8(25), LRHSCOMP, PPIV_COURANT,
1673 & MTYPE, KEEP )
1674 ENDIF
1675 ENDIF
1676 1234 CONTINUE
1677.GT..AND. IF (KEEP(201)0OOCWRITE_COMPATIBLE_WITH_BLR) THEN
1678 CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28),
1679 & A,LA,.TRUE.,IERR)
1680.LT. IF(IERR0)THEN
1681 INFO(1)=IERR
1682 INFO(2)=0
1683 GOTO 260
1684 ENDIF
1685 ENDIF
1686 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES
1687 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(IPOS))
1688 IN = INODE
1689 170 IN = FILS(IN)
1690.GT. IF (IN 0) GOTO 170
1691.EQ. IF (IN 0) THEN
1692 MYLEAF_LEFT = MYLEAF_LEFT - 1
1693.EQ..AND. ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT 0
1694.EQ. & KEEP(31) 0 )
1695.NE. IF (KEEP(31) 0) THEN
1696.NOT. IF ( MUMPS_IN_OR_ROOT_SSARBR(
1697 & PROCNODE_STEPS(STEP(INODE)),
1698 & KEEP(199) ) ) THEN
1699 KEEP(31) = KEEP(31) - 1
1700.EQ. IF (KEEP(31) 1) THEN
1701 ALLOW_OTHERS_TO_LEAVE = .TRUE.
1702 ENDIF
1703 ENDIF
1704 ENDIF
1705 IF ( ALLOW_OTHERS_TO_LEAVE ) THEN
1706 CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM,
1707 & TERMBWD, SLAVEF, KEEP )
1708 NBFINF = NBFINF - 1
1709 ENDIF
1710 IWCB( PTRICB(STEP(INODE)) + 1 ) = 0
1711 CALL DMUMPS_FREETOPSO(N, KEEP(28),
1712 & IWCB, LIWW, W, LWC,
1713 & POSWCB, POSIWCB, PTRICB, PTRACB)
1714 GOTO 270
1715 ENDIF
1716 DO I = 0, SLAVEF - 1
1717 DEJA_SEND( I ) = .FALSE.
1718 END DO
1719 IN = -IN
1720 IF ( PRUN_BELOW ) THEN
1721 NO_CHILDREN = .TRUE.
1722 ELSE
1723 NO_CHILDREN = .FALSE.
1724 ENDIF
1725.GT. DO WHILE (IN0)
1726 IF ( PRUN_BELOW ) THEN
1727.NOT. IF ( TO_PROCESS(STEP(IN)) ) THEN
1728 IN = FRERE(STEP(IN))
1729 CYCLE
1730 ELSE
1731 NO_CHILDREN = .FALSE.
1732 ENDIF
1733 ENDIF
1734 POOL_FIRST_POS = IIPOOL
1735 IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),
1736.EQ. & KEEP(199)) MYID) THEN
1737 IPOOL(IIPOOL ) = IN
1738 IIPOOL = IIPOOL + 1
1739 ELSE
1740 PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)),
1741 & KEEP(199) )
1742.NOT. IF ( DEJA_SEND( PROCDEST ) ) THEN
1743 400 CONTINUE
1744 CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0,
1745 & LIELL, LIELL - KEEP(253),
1746 & IW( POSINDICES ),
1747 & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN,
1748 & RHSCOMP(1, 1), NRHS, LRHSCOMP,
1749 & IPOSINRHSCOMP, NPIV,
1750 & KEEP, PROCDEST, NOEUD, COMM, IERR )
1751.EQ. IF ( IERR -1 ) THEN
1752 CALL DMUMPS_BACKSLV_RECV_AND_TREAT(
1753 & .FALSE., FLAG,
1754 & BUFR, LBUFR, LBUFR_BYTES,
1755 & MYID, SLAVEF, COMM,
1756 & N, IWCB, LIWW, POSIWCB,
1757 & W, LWC, POSWCB,
1758 & IIPOOL, NBFINF, PTRICB, PTRACB, INFO,
1759 & IPOOL, LPOOL, PANEL_POS, LPANEL_POS,
1760 & STEP, FRERE, FILS, PROCNODE_STEPS,
1761 & PLEFTW, KEEP, KEEP8, DKEEP,
1762 & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT,
1763 & NRHS, MTYPE,
1764 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD,
1765 & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS
1766 & , FROM_PP
1767 & )
1768.LT. IF ( INFO( 1 ) 0 ) THEN
1769 GOTO 270
1770 ENDIF
1771 GOTO 400
1772.EQ. ELSE IF ( IERR -2 ) THEN
1773 INFO( 1 ) = -17
1774 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34)
1775 GOTO 260
1776.EQ. ELSE IF ( IERR -3 ) THEN
1777 INFO( 1 ) = -20
1778 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34)
1779 GOTO 260
1780 END IF
1781 DEJA_SEND( PROCDEST ) = .TRUE.
1782 END IF
1783 END IF
1784 IN = FRERE( STEP( IN ) )
1785 END DO
1786 ALLOW_OTHERS_TO_LEAVE = .FALSE.
1787 IF (NO_CHILDREN) THEN
1788 MYLEAF_LEFT = MYLEAF_LEFT - 1
1789.EQ..AND. ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT 0
1790.EQ. & KEEP(31) 0 )
1791 ENDIF
1792.NE. IF (KEEP(31) 0) THEN
1793.NOT. IF ( MUMPS_IN_OR_ROOT_SSARBR(
1794 & PROCNODE_STEPS(STEP(INODE)),
1795 & KEEP(199) ) ) THEN
1796 KEEP(31) = KEEP(31) - 1
1797.EQ. IF (KEEP(31) 1) THEN
1798 ALLOW_OTHERS_TO_LEAVE = .TRUE.
1799 ENDIF
1800 ENDIF
1801 ENDIF
1802 IF ( ALLOW_OTHERS_TO_LEAVE ) THEN
1803 CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID,
1804 & COMM, TERMBWD, SLAVEF, KEEP )
1805 NBFINF = NBFINF - 1
1806 ENDIF
1807.NOT. IF ( NO_CHILDREN ) THEN
1808 DO I=1,(IIPOOL-POOL_FIRST_POS)/2
1809 TMP=IPOOL(POOL_FIRST_POS+I-1)
1810 IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I)
1811 IPOOL(IIPOOL-I)=TMP
1812 ENDDO
1813 ENDIF
1814 IWCB( PTRICB(STEP( INODE )) + 1 ) = 0
1815 CALL DMUMPS_FREETOPSO( N, KEEP(28),
1816 & IWCB, LIWW, W, LWC,
1817 & POSWCB, POSIWCB, PTRICB, PTRACB)
1818 END IF
1819.EQ. ELSE IF (MSGTAGTERREUR) THEN
1820 INFO(1) = -001
1821 INFO(2) = MSGSOU
1822 GO TO 270
1823.EQ..OR. ELSE IF ( (MSGTAGUPDATE_LOAD)
1824.EQ. & (MSGTAGTAG_DUMMY) ) THEN
1825 GO TO 270
1826 ELSE
1827 INFO(1) = -100
1828 INFO(2) = MSGTAG
1829 GOTO 260
1830 ENDIF
1831 GO TO 270
1832 260 CONTINUE
1833.NE. IF (NBFINF 0) THEN
1834 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
1835 ENDIF
1836 270 CONTINUE
1837 IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND)
1838 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
if
if(complex_arithmetic) id
dmumps_get_ooc_perm_ptr
subroutine dmumps_get_ooc_perm_ptr(typef, nbpanels, i_pivptr, i_piv, ipos, iw, liw)
Definition dooc_panel_piv.F:133
dmumps_ooc_pp_check_perm_freed
subroutine dmumps_ooc_pp_check_perm_freed(iw_location, must_be_permuted)
Definition dooc_panel_piv.F:349
dmumps_permute_panel
subroutine dmumps_permute_panel(ipiv, lpiv, ishift, the_panel, nbrow, nbcol, kbeforepanel)
Definition dooc_panel_piv.F:78
dmumps_solve_gemm_update
subroutine dmumps_solve_gemm_update(a, la, apos1, nx, lda, ny, nrhs_b, wcb, lwcb, ptrx, ldx, ptry, ldy, mtype, keep, coef_y)
Definition dsol_aux.F:1326
dmumps_solve_get_ooc_node
subroutine dmumps_solve_get_ooc_node(inode, ptrfac, keep, a, la, step, keep8, n, must_be_permuted, ierr)
Definition dsol_aux.F:732
dmumps_sol_bwd_gthr
subroutine dmumps_sol_bwd_gthr(jbdeb, jbfin, j1, j2, rhscomp, nrhs, lrhscomp, w, ld_w, first_row_w, iw, liw, keep, n, posinrhscomp_bwd)
Definition dsol_aux.F:1063
dmumps_compso
subroutine dmumps_compso(n, keep28, iwcb, liww, w, lwc, poswcb, iwposcb, ptricb, ptracb)
Definition dsol_aux.F:37
dmumps_backslv_recv_and_treat
recursive subroutine dmumps_backslv_recv_and_treat(bloq, flag, bufr, lbufr, lbufr_bytes, myid, slavef, comm, n, iwcb, liww, posiwcb, w, lwc, poswcb, iipool, nbfinf, ptricb, ptracb, info, ipool, lpool, panel_pos, lpanel_pos, step, frere, fils, procnode_steps, pleftw, keep, keep8, dkeep, ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left, nrhs, mtype, rhscomp, lrhscomp, posinrhscomp_bwd, prun_below, to_process, size_to_process, from_pp)
Definition dsol_bwd_aux.F:977
dmumps_build_panel_pos
subroutine dmumps_build_panel_pos(panel_size, panel_pos, len_panel_pos, indices, npiv, npanels, nfront_or_nass, nbentries_allpanels)
Definition dsol_bwd_aux.F:1844
alpha
#define alpha
Definition eval.h:35
dtrsv
subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
DTRSV
Definition dtrsv.f:143
dgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187
dtrsm
subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRSM
Definition dtrsm.f:181
mpi_unpack
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
dmumps_buf
Definition dmumps_comm_buffer.F:14
dmumps_buf::dmumps_buf_send_backvec
subroutine, public dmumps_buf_send_backvec(nrhs, inode, w, lw, ld_w, dest, msgtag, jbdeb, jbfin, keep, comm, ierr)
Definition dmumps_comm_buffer.F:2627
dmumps_ooc
Definition dmumps_ooc.F:14
dmumps_ooc::dmumps_free_factors_for_solve
subroutine dmumps_free_factors_for_solve(inode, ptrfac, nsteps, a, la, flag, ierr)
Definition dmumps_ooc.F:1204
dmumps_ooc::dmumps_ooc_panel_size
integer function, public dmumps_ooc_panel_size(nnmax)
Definition dmumps_ooc.F:3404
dmumps_sol_lr
Definition dsol_lr.F:14
dmumps_sol_lr::dmumps_sol_slave_lr_u
subroutine dmumps_sol_slave_lr_u(inode, iwhdlr, npiv_global, wcb, lwcb, ldx, ldy, ptrx_init, ptry_init, jbdeb, jbfin, mtype, keep, keep8, iflag, ierror)
Definition dsol_lr.F:189
dmumps_sol_lr::dmumps_sol_bwd_lr_su
subroutine dmumps_sol_bwd_lr_su(inode, iwhdlr, npiv_global, nslaves, liell, wcb, lwcb, nrhs_b, ptwcb, rhscomp, lrhscomp, nrhs, iposinrhscomp, jbdeb, mtype, keep, keep8, iflag, ierror)
Definition dsol_lr.F:386
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865
mumps_geti8
subroutine mumps_geti8(i8, int_array)
Definition tools_common.F:888

◆ dmumps_build_panel_pos()

subroutine dmumps_build_panel_pos ( integer, intent(in) panel_size,
integer, dimension(len_panel_pos), intent(out) panel_pos,
integer, intent(in) len_panel_pos,
integer, dimension(npiv), intent(in) indices,
integer, intent(in) npiv,
integer, intent(out) npanels,
integer, intent(in) nfront_or_nass,
integer(8), intent(out) nbentries_allpanels )

Definition at line 1840 of file dsol_bwd_aux.F.

1844 IMPLICIT NONE
1845 INTEGER, intent (in) :: PANEL_SIZE, NPIV
1846 INTEGER, intent (in) :: INDICES(NPIV)
1847 INTEGER, intent (in) :: LEN_PANEL_POS
1848 INTEGER, intent (out) :: NPANELS
1849 INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS)
1850 INTEGER, intent (in) :: NFRONT_OR_NASS
1851 INTEGER(8), intent(out):: NBENTRIES_ALLPANELS
1852 INTEGER NPANELS_MAX, I, NBeff
1853 INTEGER(8) :: NBENTRIES_THISPANEL
1854 nbentries_allpanels = 0_8
1855 npanels_max = (npiv+panel_size-1)/panel_size
1856 IF (len_panel_pos .LT. npanels_max + 1) THEN
1857 WRITE(*,*) "Error 1 in DMUMPS_BUILD_PANEL_POS",
1858 & len_panel_pos,npanels_max
1859 CALL mumps_abort()
1860 ENDIF
1861 i = 1
1862 npanels = 0
1863 IF (i .GT. npiv) RETURN
1864 10 CONTINUE
1865 npanels = npanels + 1
1866 panel_pos(npanels) = i
1867 nbeff = min(panel_size, npiv-i+1)
1868 IF ( indices(i+nbeff-1) < 0) THEN
1869 nbeff=nbeff+1
1870 ENDIF
1871 nbentries_thispanel = int(nfront_or_nass-i+1,8) * int(nbeff,8)
1872 nbentries_allpanels = nbentries_allpanels + nbentries_thispanel
1873 i=i+nbeff
1874 IF ( i .LE. npiv ) GOTO 10
1875 panel_pos(npanels+1)=npiv+1
1876 RETURN
min
#define min(a, b)
Definition macros.h:20

◆ dmumps_solve_node_bwd()

subroutine dmumps_solve_node_bwd ( integer, intent(in) inode,
integer, intent(in) n,
integer, dimension(lpool), intent(inout) ipool,
integer, intent(in) lpool,
integer, intent(inout) iipool,
integer, intent(inout) nbfinf,
double precision, dimension( la ) a,
integer(8), intent(in) la,
integer, dimension(liw) iw,
integer, intent(in) liw,
double precision, dimension(lwc) w,
integer(8), intent(in) lwc,
integer, intent(in) nrhs,
integer(8), intent(inout) poswcb,
integer(8), intent(inout) pleftw,
integer, intent(inout) posiwcb,
double precision, dimension(lrhscomp,nrhs) rhscomp,
integer lrhscomp,
integer, dimension(n) posinrhscomp_bwd,
integer, dimension(keep(28)) ptricb,
integer(8), dimension(keep(28)) ptracb,
integer, dimension(liww) iwcb,
integer, intent(in) liww,
double precision, dimension(keep(133)) w2,
integer, dimension(keep(28)), intent(in) ne_steps,
integer, dimension(n) step,
integer, dimension(keep(28)) frere,
integer, dimension(n) fils,
integer, dimension(keep(28)) ptrist,
integer(8), dimension(keep(28)) ptrfac,
integer, intent(inout) myleaf_left,
integer, dimension(80) info,
integer, dimension(keep(28)), intent(in) procnode_steps,
logical, dimension(0:slavef-1), intent(inout) deja_send,
integer, intent(in) slavef,
integer, intent(in) comm,
integer, intent(in) myid,
integer, dimension(lbufr) bufr,
integer lbufr,
integer lbufr_bytes,
integer, dimension( 500 ) keep,
integer(8), dimension(150) keep8,
double precision, dimension(230), intent(inout) dkeep,
double precision, dimension( lrhs_root ) rhs_root,
integer(8), intent(in) lrhs_root,
integer, intent(in) mtype,
integer, dimension(keep(71)) istep_to_iniv2,
integer, dimension(slavef+2,max(1,keep(56))) tab_pos_in_pere,
integer, dimension(lpanel_pos) panel_pos,
integer, intent(in) lpanel_pos,
logical, intent(in) prun_below,
logical, dimension(size_to_process), intent(in) to_process,
integer, intent(in) size_to_process,
integer, dimension(lrhs_bounds), intent(in) rhs_bounds,
integer, intent(in) lrhs_bounds,
logical, intent(in) do_nbsparse,
logical, intent(in) from_pp,
logical, intent(out) error_was_broadcasted,
logical, intent(out) do_mcast2_termbwd )

Definition at line 14 of file dsol_bwd_aux.F.

32 USE dmumps_ooc
33 USE dmumps_buf
34 USE dmumps_sol_lr, only : dmumps_sol_bwd_lr_su
35 IMPLICIT NONE
36 INTEGER :: KEEP( 500 )
37 INTEGER(8) :: KEEP8(150)
38 DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230)
39 INTEGER :: INFO(80)
40 INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW
41 INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID
42 INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28))
43 INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28))
44 INTEGER(8), INTENT( IN ) :: LA, LWC
45 INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW
46 INTEGER, INTENT( INOUT ) :: POSIWCB
47 INTEGER, INTENT( IN ) :: LPANEL_POS
48 INTEGER :: PANEL_POS(LPANEL_POS)
49 LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1)
50 INTEGER, INTENT(IN) :: LPOOL
51 INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL
52 INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT
53 INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28))
54 INTEGER(8) :: PTRACB(KEEP(28))
55 INTEGER(8) :: PTRFAC(KEEP(28))
56 DOUBLE PRECISION :: A( LA )
57 DOUBLE PRECISION :: W(LWC)
58 DOUBLE PRECISION :: W2(KEEP(133))
59 INTEGER :: IW(LIW),IWCB(LIWW)
60 INTEGER STEP(N), FRERE(KEEP(28)),FILS(N)
61 INTEGER LBUFR, LBUFR_BYTES
62 INTEGER BUFR(LBUFR)
63 INTEGER ISTEP_TO_INIV2(KEEP(71)),
64 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
65 INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N)
66 DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS)
67 INTEGER(8), intent(in) :: LRHS_ROOT
68 DOUBLE PRECISION RHS_ROOT( LRHS_ROOT )
69 LOGICAL, INTENT( IN ) :: PRUN_BELOW
70 INTEGER, INTENT(IN) :: SIZE_TO_PROCESS
71 LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS)
72 LOGICAL, INTENT(IN) :: DO_NBSPARSE
73 INTEGER, INTENT(IN) :: LRHS_BOUNDS
74 INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS)
75 LOGICAL, INTENT(IN) :: FROM_PP
76 LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED
77 LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD
78 include 'mpif.h'
79 include 'mumps_tags.h'
80 INTEGER IERR
81 LOGICAL FLAG
82 include 'mumps_headers.h'
83 LOGICAL COMPRESS_PANEL, LR_ACTIVATED
84 LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR
85 LOGICAL LTLEVEL2, IN_SUBTREE
86 INTEGER TYPENODE
87 INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR
88 LOGICAL MUST_BE_PERMUTED
89 LOGICAL NO_CHILDREN
90 LOGICAL :: ALLOW_OTHERS_TO_LEAVE
91 INTEGER :: K, JBDEB, JBFIN, NRHS_B
92 INTEGER IWHDLR
93 INTEGER NPIV
94 INTEGER IPOS,LIELL,NELIM,JJ,I
95 INTEGER J1,J2,J,NCB
96 INTEGER NSLAVES
97 INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP
98 INTEGER :: NBFILS
99 INTEGER :: PROCDEST, DEST
100 INTEGER(8) :: PTWCB, PPIV_COURANT
101 INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex
102 INTEGER :: POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL
103 INTEGER(8) :: APOS, IST
104 INTEGER(8) :: IFR8
105 INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS
106 INTEGER(8) :: PTWCB_PANEL
107 INTEGER LDAJ, NBJ, LIWFAC,
108 & NBJLAST, NPIV_LAST, PANEL_SIZE,
109 & NCB_PANEL, TYPEF
110 INTEGER BEG_PANEL
111 LOGICAL TWOBYTWO
112 INTEGER NPANELS, IPANEL
113 DOUBLE PRECISION ALPHA,ONE,ZERO
114 parameter(zero=0.0d0, one = 1.0d0, alpha=-1.0d0)
115 LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR
116 INTEGER, EXTERNAL :: MUMPS_TYPENODE
117 INTEGER, EXTERNAL :: MUMPS_PROCNODE
118 error_was_broadcasted = .false.
119 do_mcast2_termbwd = .false.
120 no_children = .false.
121 IF (do_nbsparse) THEN
122 jbdeb= rhs_bounds(2*step(inode)-1)
123 jbfin= rhs_bounds(2*step(inode))
124 nrhs_b = jbfin-jbdeb+1
125 ELSE
126 jbdeb = 1
127 jbfin = nrhs
128 nrhs_b = nrhs
129 ENDIF
130 IF ( inode .EQ. keep( 38 ) .OR. inode .EQ. keep( 20 ) ) THEN
131 ipos = ptrist(step(inode))+keep(ixsz)
132 npiv = iw(ipos+3)
133 liell = iw(ipos) + npiv
134 ipos = ptrist(step(inode)) + 5 + keep(ixsz)
135 IF ( mtype .EQ. 1 .AND. keep(50) .EQ. 0) THEN
136 j1 = ipos + liell + 1
137 j2 = ipos + liell + npiv
138 ELSE
139 j1 = ipos + 1
140 j2 = ipos + npiv
141 END IF
142 ifr8 = 0_8
143 iposinrhscomp = posinrhscomp_bwd(iw(j1))
144 CALL dmumps_sol_cpy_fs2rhscomp(jbdeb, jbfin, j2-j1+1,
145 & keep, rhscomp, nrhs, lrhscomp, iposinrhscomp,
146 & rhs_root(1+npiv*(jbdeb-1)), npiv, 1)
147 in = inode
148 270 in = fils(in)
149 IF (in .GT. 0) GOTO 270
150 IF (in .EQ. 0) THEN
151 myleaf_left = myleaf_left - 1
152 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
153 & keep(31) .EQ. 0)
154 IF (keep(31) .NE. 0) THEN
155 IF ( .NOT. mumps_in_or_root_ssarbr(
156 & procnode_steps(step(inode)), keep(199) ) ) THEN
157 keep(31) = keep(31) - 1
158 IF (keep(31) .EQ. 1) THEN
159 allow_others_to_leave = .true.
160 ENDIF
161 ENDIF
162 ENDIF
163 IF (allow_others_to_leave) THEN
164 do_mcast2_termbwd = .true.
165 nbfinf = nbfinf - 1
166 ENDIF
167 RETURN
168 ENDIF
169 IF = -in
170 long = npiv
171 nbfils = ne_steps(step(inode))
172 IF ( prun_below ) THEN
173 i = nbfils
174 nbfils = 0
175 DO WHILE (i.GT.0)
176 IF ( to_process(step(if)) ) nbfils = nbfils+1
177 IF = frere(step(if))
178 i = i -1
179 ENDDO
180 IF (nbfils.EQ.0) THEN
181 no_children = .true.
182 ELSE
183 no_children = .false.
184 ENDIF
185 IF = -in
186 ENDIF
187 DO i = 0, slavef - 1
188 deja_send( i ) = .false.
189 END DO
190 pool_first_pos=iipool
191 DO i = 1, nbfils
192 IF ( prun_below ) THEN
193 1030 IF ( .NOT.to_process(step(if)) ) THEN
194 IF = frere(step(if))
195 GOTO 1030
196 ENDIF
197 no_children = .false.
198 ENDIF
199 IF (mumps_procnode(procnode_steps(step(if)),keep(199))
200 & .EQ. myid) THEN
201 ipool(iipool) = IF
202 iipool = iipool + 1
203 ELSE
204 procdest = mumps_procnode(procnode_steps(step(if)),
205 & keep(199))
206 IF (.NOT. deja_send( procdest )) THEN
207 600 CONTINUE
208 CALL dmumps_buf_send_vcb( nrhs_b, IF, 0, 0,
209 & long, long, iw( j1 ),
210 & rhs_root( 1+npiv*(jbdeb-1) ),
211 & jbdeb, jbfin,
212 & rhscomp(1, 1), nrhs, lrhscomp,
213 & iposinrhscomp, npiv,
214 & keep, procdest,
215 & noeud, comm, ierr )
216 IF ( ierr .EQ. -1 ) THEN
217 CALL dmumps_backslv_recv_and_treat(
218 & .false., flag,
219 & bufr, lbufr, lbufr_bytes,
220 & myid, slavef, comm,
221 & n, iwcb, liww, posiwcb,
222 & w, lwc, poswcb,
223 & iipool, nbfinf, ptricb, ptracb, info,
224 & ipool, lpool, panel_pos, lpanel_pos,
225 & step, frere, fils, procnode_steps,
226 & pleftw, keep,keep8, dkeep,
227 & ptrist, ptrfac, iw, liw, a, la, w2,
228 & myleaf_left,
229 & nrhs, mtype,
230 & rhscomp, lrhscomp, posinrhscomp_bwd,
231 & prun_below, to_process, size_to_process
232 & , from_pp
233 & )
234 IF ( info( 1 ) .LT. 0 ) THEN
235 error_was_broadcasted = .true.
236 RETURN
237 ENDIF
238 GOTO 600
239 ELSE IF ( ierr .EQ. -2 ) THEN
240 info( 1 ) = -17
241 info( 2 ) = nrhs_b * long * keep(35) +
242 & ( long + 4 ) * keep(34)
243 error_was_broadcasted = .false.
244 RETURN
245 ELSE IF ( ierr .EQ. -3 ) THEN
246 info( 1 ) = -20
247 info( 2 ) = nrhs_b * long * keep(35) +
248 & ( long + 4 ) * keep(34)
249 error_was_broadcasted = .false.
250 RETURN
251 ELSE IF ( ierr .NE. 0 ) THEN
252 WRITE(*,*) "Internal error 2 DMUMPS_SOLVE_NODE_BWD",
253 & ierr
254 CALL mumps_abort()
255 END IF
256 deja_send( procdest ) = .true.
257 END IF
258 ENDIF
259 IF = frere(step(if))
260 ENDDO
261 allow_others_to_leave = .false.
262 IF ( prun_below .AND. no_children ) THEN
263 myleaf_left = myleaf_left - 1
264 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
265 & keep(31) .EQ. 0)
266 ENDIF
267 IF ( keep(31). ne. 0) THEN
268 IF ( .NOT. mumps_in_or_root_ssarbr(
269 & procnode_steps(step(inode)), keep(199) ) ) THEN
270 keep(31) = keep(31) - 1
271 IF (keep(31) .EQ. 1) THEN
272 allow_others_to_leave = .true.
273 ENDIF
274 ENDIF
275 ENDIF
276 IF ( allow_others_to_leave ) THEN
277 do_mcast2_termbwd = .true.
278 nbfinf = nbfinf - 1
279 ENDIF
280 IF (iipool.NE.pool_first_pos) THEN
281 DO i=1,(iipool-pool_first_pos)/2
282 tmp = ipool(pool_first_pos+i-1)
283 ipool(pool_first_pos+i-1) = ipool(iipool-i)
284 ipool(iipool-i) = tmp
285 ENDDO
286 ENDIF
287 RETURN
288 END IF
289 in_subtree = mumps_in_or_root_ssarbr(
290 & procnode_steps(step(inode)), keep(199) )
291 typenode = mumps_typenode(procnode_steps(step(inode)),
292 & keep(199))
293 ltlevel2= (
294 & (typenode .eq.2 ) .AND.
295 & (mtype.NE.1) )
296 npiv = iw(ptrist(step(inode))+2+keep(ixsz)+1)
297 IF ((npiv.NE.0).AND.(ltlevel2)) THEN
298 ipos = ptrist(step(inode)) + 2 + keep(ixsz)
299 liell = iw(ipos-2)+iw(ipos+1)
300 nelim = iw(ipos-1)
301 ipos = ipos + 1
302 npiv = iw(ipos)
303 ncb = liell - npiv - nelim
304 ipos = ipos + 2
305 nslaves = iw( ipos )
306 offset = 0
307 ipos = ipos + nslaves
308 iw(ptrist(step(inode))+xxs)= c_fini+nslaves
309 IF ( posiwcb - 2 .LT. 0 .or.
310 & poswcb-int(ncb,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
311 CALL dmumps_compso( n, keep(28), iwcb, liww, w, lwc,
312 & poswcb, posiwcb, ptricb, ptracb)
313 IF ( poswcb-int(ncb,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
314 info( 1 ) = -11
315 CALL mumps_set_ierror(ncb * nrhs_b - poswcb-pleftw+1_8,
316 & info(2))
317 error_was_broadcasted = .false.
318 RETURN
319 END IF
320 IF ( posiwcb - 2 .LT. 0 ) THEN
321 info( 1 ) = -14
322 info( 2 ) = 2 - posiwcb
323 error_was_broadcasted = .false.
324 RETURN
325 END IF
326 END IF
327 posiwcb = posiwcb - 2
328 poswcb = poswcb - int(ncb,8)*int(nrhs_b,8)
329 ptricb(step( inode )) = posiwcb + 1
330 ptracb(step( inode )) = poswcb + 1_8
331 iwcb( ptricb(step( inode )) ) = ncb*nrhs_b
332 iwcb( ptricb(step( inode )) + 1 ) = 1
333 IF ( mtype.EQ.1 .AND. keep(50).EQ.0 ) THEN
334 posindices = ipos + liell + 1
335 ELSE
336 posindices = ipos + 1
337 END IF
338 IF ( ncb.EQ.0 ) THEN
339 write(6,*) ' Internal Error type 2 node with no CB '
340 CALL mumps_abort()
341 ENDIF
342 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
343 j1 = ipos + liell + npiv + nelim +1
344 j2 = ipos + 2 * liell
345 ELSE
346 j1 = ipos + npiv + nelim +1
347 j2 = ipos + liell
348 END IF
349 ifr8 = ptracb(step( inode )) - 1_8
350 CALL dmumps_sol_bwd_gthr( jbdeb, jbfin, j1, j2,
351 & rhscomp, nrhs, lrhscomp,
352 & w(ptracb(step(inode))), ncb, 1,
353 & iw, liw, keep, n, posinrhscomp_bwd )
354 ifr8 = ifr8 + int(j2-keep(253)-j1+1,8)
355 IF (keep(252).NE.0) THEN
356 DO jj = j2-keep(253)+1, j2
357 ifr8 = ifr8 + 1_8
358 DO k=jbdeb, jbfin
359 IF (k.EQ.jj-j2+keep(253)) THEN
360 w(ifr8+int(k-jbdeb,8)*int(ncb,8)) = alpha
361 ELSE
362 w(ifr8+int(k-jbdeb,8)*int(ncb,8)) = zero
363 ENDIF
364 ENDDO
365 ENDDO
366 ENDIF
367 DO islave = 1, nslaves
368 CALL mumps_bloc2_get_slave_info(
369 & keep,keep8, inode, step, n, slavef,
370 & istep_to_iniv2, tab_pos_in_pere,
371 & islave, ncb,
372 & nslaves,
373 & effectivesize,
374 & firstindex )
375 500 CONTINUE
376 dest = iw( ptrist(step(inode))+5+islave+keep(ixsz))
377 CALL dmumps_buf_send_backvec(nrhs_b, inode,
378 & w(offset+ptracb(step(inode))),
379 & effectivesize,
380 & ncb, dest,
381 & backslv_master2slave, jbdeb, jbfin,
382 & keep, comm, ierr )
383 IF ( ierr .EQ. -1 ) THEN
384 CALL dmumps_backslv_recv_and_treat(
385 & .false., flag,
386 & bufr, lbufr, lbufr_bytes,
387 & myid, slavef, comm,
388 & n, iwcb, liww, posiwcb,
389 & w, lwc, poswcb,
390 & iipool, nbfinf, ptricb, ptracb, info,
391 & ipool, lpool, panel_pos, lpanel_pos,
392 & step, frere, fils,
393 & procnode_steps, pleftw, keep,keep8, dkeep,
394 & ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left,
395 & nrhs, mtype,
396 & rhscomp, lrhscomp, posinrhscomp_bwd,
397 & prun_below , to_process, size_to_process
398 & , from_pp
399 & )
400 IF ( info( 1 ) .LT. 0 ) THEN
401 error_was_broadcasted = .true.
402 RETURN
403 ENDIF
404 GOTO 500
405 ELSE IF ( ierr .EQ. -2 ) THEN
406 info( 1 ) = -17
407 info( 2 ) = nrhs_b * effectivesize * keep(35) +
408 & 2 * keep(34)
409 error_was_broadcasted = .false.
410 RETURN
411 ELSE IF ( ierr .EQ. -3 ) THEN
412 info( 1 ) = -20
413 info( 2 ) = nrhs_b * effectivesize * keep(35) +
414 & 2 * keep(34)
415 error_was_broadcasted = .false.
416 RETURN
417 END IF
418 offset = offset + effectivesize
419 END DO
420 iwcb( ptricb(step( inode )) + 1 ) = 0
421 CALL dmumps_freetopso(n, keep(28), iwcb, liww, w, lwc,
422 & poswcb,posiwcb,ptricb,ptracb)
423 RETURN
424 ENDIF
425 lr_activated = (iw(ptrist(step(inode))+xxlr).GT.0)
426 compress_panel = (iw(ptrist(step(inode))+xxlr).GE.2)
427 oocwrite_compatible_with_blr =
428 & (.NOT.lr_activated.OR.(.NOT.compress_panel).OR.
429 & (keep(485).EQ.0)
430 & )
431 ipos = ptrist(step(inode)) + 2 + keep(ixsz)
432 liell = iw(ipos-2)+iw(ipos+1)
433 nelim = iw(ipos-1)
434 ipos = ipos + 1
435 npiv = iw(ipos)
436 ncb = liell - npiv
437 ipos = ipos + 1
438 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr) THEN
439 CALL dmumps_solve_get_ooc_node(
440 & inode,ptrfac,keep,a,la,step,
441 & keep8,n,must_be_permuted,ierr)
442 IF(ierr.LT.0)THEN
443 info(1)=ierr
444 info(2)=0
445 error_was_broadcasted = .false.
446 RETURN
447 ENDIF
448 ENDIF
449 apos = ptrfac( step(inode))
450 nslaves = iw( ptrist(step(inode)) + 5 + keep(ixsz) )
451 ipos = ipos + 1 + nslaves
452 IF (keep(201).EQ.1.AND.oocwrite_compatible_with_blr) THEN
453 liwfac = iw(ptrist(step(inode))+xxi)
454 IF (mtype.NE.1) THEN
455 typef = typef_l
456 ELSE
457 typef = typef_u
458 ENDIF
459 panel_size = dmumps_ooc_panel_size( liell )
460 IF (keep(50).NE.1) THEN
461 CALL dmumps_ooc_pp_check_perm_freed(
462 & iw(ipos+1+2*liell),
463 & must_be_permuted )
464 ENDIF
465 ENDIF
466 long = 0
467 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
468 j1 = ipos + liell + 1
469 j2 = ipos + npiv + liell
470 ELSE
471 j1 = ipos + 1
472 j2 = ipos + npiv
473 ENDIF
474 IF (in_subtree) THEN
475 ptwcb = pleftw
476 IF ( poswcb .LT. int(liell,8)*int(nrhs_b,8) ) THEN
477 CALL dmumps_compso( n, keep(28), iwcb, liww, w, lwc,
478 & poswcb, posiwcb, ptricb, ptracb)
479 IF ( poswcb .LT. int(liell,8)*int(nrhs_b,8) ) THEN
480 info(1) = -11
481 CALL mumps_set_ierror(int(liell,8)*int(nrhs_b,8)-poswcb,
482 & info(2))
483 error_was_broadcasted = .false.
484 RETURN
485 END IF
486 END IF
487 ELSE
488 IF ( posiwcb - 2 .LT. 0 .or.
489 & poswcb-int(liell,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
490 CALL dmumps_compso( n, keep(28), iwcb, liww, w, lwc,
491 & poswcb, posiwcb, ptricb, ptracb )
492 IF ( poswcb-int(liell,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
493 info( 1 ) = -11
494 CALL mumps_set_ierror( int(liell,8)*int(nrhs_b,8)-
495 & poswcb-pleftw+1_8,
496 & info(2) )
497 error_was_broadcasted = .false.
498 RETURN
499 END IF
500 IF ( posiwcb - 2 .LT. 0 ) THEN
501 info( 1 ) = -14
502 info( 2 ) = 2 - posiwcb
503 error_was_broadcasted = .false.
504 RETURN
505 END IF
506 END IF
507 posiwcb = posiwcb - 2
508 poswcb = poswcb - int(liell,8)*int(nrhs_b,8)
509 ptricb(step( inode )) = posiwcb + 1
510 ptracb(step( inode )) = poswcb + 1_8
511 iwcb( ptricb(step( inode )) ) = liell*nrhs_b
512 iwcb( ptricb(step( inode )) + 1 ) = 1
513 IF ( mtype.EQ.1 .AND. keep(50).EQ.0 ) THEN
514 posindices = ipos + liell + 1
515 ELSE
516 posindices = ipos + 1
517 END IF
518 ptwcb = ptracb(step( inode ))
519 ENDIF
520 IF (j2.GE.j1) THEN
521 iposinrhscomp = posinrhscomp_bwd(iw(j1))
522 ELSE
523 iposinrhscomp = -99999
524 ENDIF
525 IF (j2.GE.j1) THEN
526 DO k=jbdeb, jbfin
527 IF (keep(252).NE.0) THEN
528 DO jj = j1, j2
529 rhscomp(iposinrhscomp+jj-j1,k) = zero
530 ENDDO
531 ENDIF
532 END DO
533 ENDIF
534 ifr8 = ptwcb + int(npiv - 1,8)
535 IF ( liell .GT. npiv ) THEN
536 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
537 j1 = ipos + liell + npiv + 1
538 j2 = ipos + 2 * liell
539 ELSE
540 j1 = ipos + npiv + 1
541 j2 = ipos + liell
542 END IF
543 CALL dmumps_sol_bwd_gthr( jbdeb, jbfin, j1, j2,
544 & rhscomp, nrhs, lrhscomp,
545 & w(ptwcb), liell, npiv+1,
546 & iw, liw, keep, n, posinrhscomp_bwd )
547 ifr8 = ifr8 + int(j2-keep(253)-j1+1,8)
548 IF (keep(252).NE.0) THEN
549 DO jj = j2-keep(253)+1, j2
550 ifr8 = ifr8 + 1_8
551 DO k=jbdeb, jbfin
552 IF (k.EQ.jj-j2+keep(253)) THEN
553 w(ifr8+int(k-jbdeb,8)*int(liell,8)) = alpha
554 ELSE
555 w(ifr8+int(k-jbdeb,8)*int(liell,8)) = zero
556 ENDIF
557 ENDDO
558 ENDDO
559 ENDIF
560 ncb = liell - npiv
561 IF (npiv .EQ. 0) GOTO 160
562 ENDIF
563 IF (keep(201).EQ.1.AND.oocwrite_compatible_with_blr) THEN
564 j = npiv / panel_size
565 twobytwo = keep(50).EQ.2 .AND.
566 & ((typenode.EQ.1.AND.keep(103).GT.0) .OR.
567 & (typenode.EQ.2.AND.keep(105).GT.0))
568 IF (twobytwo) THEN
569 CALL dmumps_build_panel_pos(panel_size, panel_pos, lpanel_pos,
570 & iw(ipos+1+liell), npiv, npanels, liell,
571 & nbentries_allpanels)
572 ELSE
573 IF (npiv.EQ.j*panel_size) THEN
574 npiv_last = npiv
575 nbjlast = panel_size
576 npanels = j
577 ELSE
578 npiv_last = (j+1)* panel_size
579 nbjlast = npiv-j*panel_size
580 npanels = j+1
581 ENDIF
582 nbentries_allpanels =
583 & int(liell,8) * int(npiv,8)
584 & - int( ( j * ( j - 1 ) ) /2,8 )
585 & * int(panel_size,8) * int(panel_size,8)
586 & - int(j,8)
587 & * int(mod(npiv, panel_size),8)
588 & * int(panel_size,8)
589 jj=npiv_last
590 ENDIF
591 aposdeb = apos + nbentries_allpanels
592 DO ipanel = npanels, 1, -1
593 IF (twobytwo) THEN
594 nbj = panel_pos(ipanel+1)-panel_pos(ipanel)
595 beg_panel = panel_pos(ipanel)
596 ELSE
597 IF (jj.EQ.npiv_last) THEN
598 nbj = nbjlast
599 ELSE
600 nbj = panel_size
601 ENDIF
602 beg_panel = jj- panel_size+1
603 ENDIF
604 ldaj = liell-beg_panel+1
605 aposdeb = aposdeb - int(nbj,8)*int(ldaj,8)
606 ptwcb_panel = ptwcb + int(beg_panel - 1,8)
607 iposinrhscomp_panel = iposinrhscomp + beg_panel - 1
608 ncb_panel = ldaj - nbj
609 IF (keep(50).NE.1.AND.must_be_permuted) THEN
610 CALL dmumps_get_ooc_perm_ptr(typef, tmp_nbpanels,
611 & i_pivrptr, i_pivr, ipos + 1 + 2 * liell, iw, liw)
612 IF (npiv.EQ.(iw(i_pivrptr)-1)) THEN
613 must_be_permuted=.false.
614 ELSE
615 CALL dmumps_permute_panel(
616 & iw(i_pivr + iw(i_pivrptr+ipanel-1)-iw(i_pivrptr)),
617 & npiv-iw(i_pivrptr+ipanel-1)+1,
618 & iw(i_pivrptr+ipanel-1)-1,
619 & a(aposdeb),
620 & ldaj, nbj, beg_panel-1)
621 ENDIF
622 ENDIF
623#if defined(MUMPS_USE_BLAS2)
624 IF ( nrhs_b == 1 ) THEN
625 IF (ncb_panel.NE.0) THEN
626 IF (ncb_panel - ncb.NE. 0) THEN
627 CALL dgemv( 'T', ncb_panel-ncb, nbj, alpha,
628 & a( aposdeb + int(nbj,8) ), ldaj,
629 & rhscomp(iposinrhscomp_panel+nbj,jbdeb),
630 & 1, one,
631 & rhscomp(iposinrhscomp_panel,jbdeb), 1 )
632 ENDIF
633 IF (ncb .NE. 0) THEN
634 CALL dgemv( 'T', ncb, nbj, alpha,
635 & a( aposdeb + int(ldaj-ncb,8) ), ldaj,
636 & w( ptwcb + int(npiv,8) ),
637 & 1, one,
638 & rhscomp(iposinrhscomp_panel,jbdeb), 1 )
639 ENDIF
640 ENDIF
641 IF (mtype.NE.1) THEN
642 CALL dtrsv('L','T','U', nbj, a(aposdeb), ldaj,
643 & rhscomp(iposinrhscomp_panel,jbdeb), 1)
644 ELSE
645 CALL dtrsv('L','T','N', nbj, a(aposdeb), ldaj,
646 & rhscomp(iposinrhscomp_panel,jbdeb), 1)
647 ENDIF
648 ELSE
649#endif
650 IF (ncb_panel.NE.0) THEN
651 IF (ncb_panel - ncb .NE. 0) THEN
652 CALL dgemm( 'T', 'N', nbj, nrhs_b,
653 & ncb_panel-ncb, alpha,
654 & a(aposdeb +int(nbj,8)), ldaj,
655 & rhscomp(iposinrhscomp_panel+nbj,jbdeb), lrhscomp,
656 & one, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
657 ENDIF
658 IF (ncb .NE. 0) THEN
659 CALL dgemm( 'T', 'N', nbj, nrhs_b, ncb, alpha,
660 & a(aposdeb +int(ldaj-ncb,8)), ldaj,
661 & w( ptwcb+int(npiv,8) ), liell,
662 & one, rhscomp(iposinrhscomp_panel,jbdeb),lrhscomp)
663 ENDIF
664 ENDIF
665 IF (mtype.NE.1) THEN
666 CALL dtrsm('L','L','T','U',nbj, nrhs_b, one,
667 & a(aposdeb),
668 & ldaj, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
669 ELSE
670 CALL dtrsm('L','L','T','N',nbj, nrhs_b, one,
671 & a(aposdeb),
672 & ldaj, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
673 ENDIF
674#if defined(MUMPS_USE_BLAS2)
675 ENDIF
676#endif
677 IF (.NOT. twobytwo) jj=beg_panel-1
678 ENDDO
679 ELSE
680 IF ( iw(ptrist(step(inode))+xxlr) .GE. 2
681 & .AND. keep(485) .EQ. 1 ) THEN
682 iwhdlr = iw(ptrist(step(inode))+xxf)
683 CALL dmumps_sol_bwd_lr_su (
684 & inode, iwhdlr, npiv, nslaves,
685 & liell, w, lwc, nrhs_b, ptwcb,
686 & rhscomp, lrhscomp, nrhs,
687 & iposinrhscomp, jbdeb,
688 & mtype, keep, keep8,
689 & info(1), info(2) )
690 IF (info(1).LT.0) THEN
691 error_was_broadcasted = .false.
692 RETURN
693 ENDIF
694 ELSE
695 IF ( liell .GT. npiv ) THEN
696#if defined(LDLTPANEL_DEBUG)
697 WRITE(*,*) 'before gemm LIELL, NPIV, PTWCB=',liell,npiv,ptwcb
698 WRITE(*,*) 'before gemm RHSCOMP=',
699 & rhscomp(iposinrhscomp:iposinrhscomp+npiv-1,1)
700 WRITE(*,*) 'before gemm W',
701 & w(ptwcb+npiv:ptwcb+liell-1)
702 CALL mumps_geti8(ist, iw(ptrist(step(inode))+xxr))
703 WRITE(*,*) "FACTORS=",a(apos:apos+ist-1)
704#endif
705 IF ( mtype .eq. 1 ) THEN
706 ist = apos + int(npiv,8)
707#if defined(MUMPS_USE_BLAS2)
708 IF (nrhs_b == 1) THEN
709 CALL dgemv( 'T', ncb, npiv, alpha, a(ist), liell,
710 & w(ptwcb+int(npiv,8)), 1,
711 & one,
712 & rhscomp(iposinrhscomp,jbdeb), 1 )
713 ELSE
714#endif
715 CALL dgemm('T','N', npiv, nrhs_b, ncb, alpha,
716 & a(ist),
717 & liell, w(ptwcb+int(npiv,8)), liell, one,
718 & rhscomp(iposinrhscomp,jbdeb), lrhscomp)
719#if defined(MUMPS_USE_BLAS2)
720 ENDIF
721#endif
722 ELSE
723 IF ( keep(50) .eq. 0 ) THEN
724 ist = apos + int(npiv,8) * int(liell,8)
725 ELSE
726 IF( keep(459) .GT. 1) THEN
727 CALL mumps_geti8(ist, iw(ptrist(step(inode))+xxr))
728 ist = apos + ist - int(npiv,8) * int(liell-npiv,8)
729 ELSE
730 ist = apos + int(npiv,8) * int(npiv,8)
731 ENDIF
732 END IF
733#if defined(MUMPS_USE_BLAS2)
734 IF ( nrhs_b == 1 ) THEN
735 CALL dgemv( 'N', npiv, ncb, alpha, a( ist ), npiv,
736 & w( ptwcb + int(npiv,8) ),
737 & 1, one,
738 & rhscomp(iposinrhscomp,jbdeb), 1 )
739 ELSE
740#endif
741 CALL dgemm( 'N', 'N', npiv, nrhs_b, ncb, alpha,
742 & a(ist),
743 & npiv, w(ptwcb+int(npiv,8)), liell,
744 & one, rhscomp(iposinrhscomp,jbdeb), lrhscomp)
745#if defined(MUMPS_USE_BLAS2)
746 END IF
747#endif
748 END IF
749 ENDIF
750 IF ( mtype .eq. 1 ) THEN
751 ldaj = liell
752 ELSE
753 IF ( keep(50) .EQ. 0 ) THEN
754 ldaj=liell
755 ELSE
756 IF (keep(459).GT.1) THEN
757 ldaj=-999799
758 ELSE
759 ldaj=npiv
760 ENDIF
761 ENDIF
762 END IF
763 ppiv_courant = int(jbdeb-1,8)*int(lrhscomp,8)
764 & + int(iposinrhscomp,8)
765 IF (keep(459).GT.1 .AND. keep(50).NE.0) THEN
766 CALL dmumps_solve_bwd_panels( a, la, apos,
767 & npiv, iw(ipos+1+liell),
768 & nrhs_b, rhscomp(1,1), keep8(25), lrhscomp, ppiv_courant,
769 & mtype, keep )
770 ELSE
771 CALL dmumps_solve_bwd_trsolve( a, la, apos,
772 & npiv, ldaj,
773 & nrhs_b, rhscomp(1,1), keep8(25), lrhscomp, ppiv_courant,
774 & mtype, keep )
775 ENDIF
776 ENDIF
777 ENDIF
778 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0) THEN
779 j1 = ipos + liell + 1
780 ELSE
781 j1 = ipos + 1
782 END IF
783 iposinrhscomp = posinrhscomp_bwd(iw(j1))
784 160 CONTINUE
785 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr) THEN
786 CALL dmumps_free_factors_for_solve(inode,ptrfac,keep(28),
787 & a,la,.true.,ierr)
788 IF(ierr.LT.0)THEN
789 info(1)=ierr
790 info(2)=0
791 error_was_broadcasted = .false.
792 RETURN
793 ENDIF
794 ENDIF
795 in = inode
796 170 in = fils(in)
797 IF (in .GT. 0) GOTO 170
798 IF (in .EQ. 0) THEN
799 myleaf_left = myleaf_left - 1
800 IF (.NOT. in_subtree ) THEN
801 iwcb(ptricb(step(inode))+1) = iwcb(ptricb(step(inode))+1)-1
802 CALL dmumps_freetopso(n, keep(28), iwcb, liww,
803 & w, lwc,
804 & poswcb,posiwcb,ptricb,ptracb)
805 ENDIF
806 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
807 & keep(31) .EQ. 0)
808 IF ( keep(31) .NE. 0 .AND.
809 & .NOT. in_subtree ) THEN
810 keep(31) = keep(31) - 1
811 IF (keep(31).EQ. 1) THEN
812 allow_others_to_leave = .true.
813 ENDIF
814 ENDIF
815 IF (allow_others_to_leave) THEN
816 do_mcast2_termbwd = .true.
817 nbfinf = nbfinf - 1
818 ENDIF
819 RETURN
820 ENDIF
821 IF = -in
822 nbfils = ne_steps(step(inode))
823 IF ( prun_below ) THEN
824 i = nbfils
825 nbfils = 0
826 DO WHILE (i.GT.0)
827 IF ( to_process(step(if)) ) nbfils = nbfils+1
828 IF = frere(step(if))
829 i = i -1
830 ENDDO
831 IF (nbfils.EQ.0) THEN
832 no_children = .true.
833 ELSE
834 no_children = .false.
835 ENDIF
836 IF = -in
837 ENDIF
838 IF (in_subtree) THEN
839 DO i = 1, nbfils
840 IF ( prun_below ) THEN
841 1010 CONTINUE
842 IF ( .NOT.to_process(step(if)) ) THEN
843 IF = frere(step(if))
844 GOTO 1010
845 ENDIF
846 no_children = .false.
847 ENDIF
848 ipool((iipool-i+1)+nbfils-i) = IF
849 iipool = iipool + 1
850 IF = frere(step(if))
851 ENDDO
852 IF (prun_below .AND. no_children) THEN
853 myleaf_left = myleaf_left - 1
854 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
855 & keep(31) .EQ. 0)
856 IF (allow_others_to_leave ) THEN
857 do_mcast2_termbwd = .true.
858 nbfinf = nbfinf - 1
859 RETURN
860 ENDIF
861 ENDIF
862 ELSE
863 DO i = 0, slavef - 1
864 deja_send( i ) = .false.
865 END DO
866 pool_first_pos=iipool
867 DO 190 i = 1, nbfils
868 IF ( prun_below ) THEN
8691020 IF ( .NOT.to_process(step(if)) ) THEN
870 IF = frere(step(if))
871 GOTO 1020
872 ENDIF
873 no_children = .false.
874 ENDIF
875 IF (mumps_procnode(procnode_steps(step(if)),
876 & keep(199)) .EQ. myid) THEN
877 ipool(iipool) = IF
878 iipool = iipool + 1
879 IF = frere(step(if))
880 ELSE
881 procdest = mumps_procnode(procnode_steps(step(if)),
882 & keep(199))
883 IF (.not. deja_send( procdest )) THEN
884 400 CONTINUE
885 CALL dmumps_buf_send_vcb( nrhs_b, IF, 0, 0,
886 & liell, liell - keep(253),
887 & iw( posindices ),
888 & w( ptracb(step(inode)) ), jbdeb, jbfin,
889 & rhscomp(1, 1), nrhs, lrhscomp,
890 & iposinrhscomp, npiv,
891 & keep, procdest, noeud, comm, ierr )
892 IF ( ierr .EQ. -1 ) THEN
893 CALL dmumps_backslv_recv_and_treat(
894 & .false., flag,
895 & bufr, lbufr, lbufr_bytes,
896 & myid, slavef, comm,
897 & n, iwcb, liww, posiwcb,
898 & w, lwc, poswcb,
899 & iipool, nbfinf, ptricb, ptracb, info,
900 & ipool, lpool, panel_pos, lpanel_pos,
901 & step, frere, fils, procnode_steps,
902 & pleftw, keep, keep8, dkeep,
903 & ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left,
904 & nrhs, mtype,
905 & rhscomp, lrhscomp, posinrhscomp_bwd,
906 & prun_below, to_process, size_to_process
907 & , from_pp
908 & )
909 IF ( info( 1 ) .LT. 0 ) THEN
910 error_was_broadcasted = .true.
911 RETURN
912 ENDIF
913 GOTO 400
914 ELSE IF ( ierr .EQ. -2 ) THEN
915 info( 1 ) = -17
916 info( 2 ) = nrhs_b * liell * keep(35) + 4 * keep(34)
917 error_was_broadcasted = .false.
918 RETURN
919 ELSE IF ( ierr .EQ. -3 ) THEN
920 info( 1 ) = -20
921 info( 2 ) = nrhs_b * liell * keep(35) + 4 * keep(34)
922 error_was_broadcasted = .false.
923 RETURN
924 END IF
925 deja_send( procdest ) = .true.
926 END IF
927 IF = frere(step(if))
928 ENDIF
929 190 CONTINUE
930 IF ( prun_below .AND. no_children ) THEN
931 myleaf_left = myleaf_left - 1
932 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
933 & keep(31) .EQ. 0)
934 IF ( allow_others_to_leave ) THEN
935 do_mcast2_termbwd = .true.
936 nbfinf = nbfinf - 1
937 RETURN
938 ENDIF
939 ENDIF
940 DO i=1,(iipool-pool_first_pos)/2
941 tmp=ipool(pool_first_pos+i-1)
942 ipool(pool_first_pos+i-1)=ipool(iipool-i)
943 ipool(iipool-i)=tmp
944 ENDDO
945 IF ( keep(31) .NE. 0 )
946 & THEN
947 keep(31) = keep(31) - 1
948 allow_others_to_leave = (keep(31) .EQ. 1)
949 IF (allow_others_to_leave) THEN
950 do_mcast2_termbwd = .true.
951 nbfinf = nbfinf - 1
952 ENDIF
953 ENDIF
954 iwcb(ptricb(step(inode))+1) = iwcb(ptricb(step(inode))+1)-1
955 CALL dmumps_freetopso(n, keep(28), iwcb, liww,
956 & w, lwc,
957 & poswcb,posiwcb,ptricb,ptracb)
958 ENDIF
959 RETURN
dmumps_solve_bwd_panels
subroutine dmumps_solve_bwd_panels(a, la, apos, npiv, iw, nrhs_b, wcb, lwcb, lda_wcb, ppiv_courant, mtype, keep)
Definition dsol_aux.F:1274
dmumps_freetopso
subroutine dmumps_freetopso(n, keep28, iwcb, liww, w, lwc, poswcb, iwposcb, ptricb, ptracb)
Definition dsol_aux.F:17
dmumps_solve_bwd_trsolve
subroutine dmumps_solve_bwd_trsolve(a, la, apos, npiv, ldadiag, nrhs_b, wcb, lwcb, lda_wcb, ppiv_courant, mtype, keep)
Definition dsol_aux.F:1185
dmumps_sol_cpy_fs2rhscomp
subroutine dmumps_sol_cpy_fs2rhscomp(jbdeb, jbfin, nbrows, keep, rhscomp, nrhs, lrhscomp, first_row_rhscomp, w, ld_w, first_row_w)
Definition dsol_aux.F:1040
mumps_bloc2_get_slave_info
subroutine mumps_bloc2_get_slave_info(keep, keep8, inode, step, n, slavef, istep_to_iniv2, tab_pos_in_pere islave, ncb, nslaves, size, first_index)
Definition mumps_type2_blocking.F:367
dmumps_buf::dmumps_buf_send_vcb
subroutine, public dmumps_buf_send_vcb(nrhs_b, node1, node2, ncb, ldw, long, iw, w, jbdeb, jbfin, rhscomp, nrhs, lrhscomp, iposinrhscomp, npiv, keep, dest, tag, comm, ierr)
Definition dmumps_comm_buffer.F:505
mumps_in_or_root_ssarbr
logical function mumps_in_or_root_ssarbr(procinfo_inode, k199)
Definition tools_common.F:214
mumps_typenode
integer function mumps_typenode(procinfo_inode, k199)
Definition tools_common.F:90