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

Go to the source code of this file.

Functions/Subroutines

subroutine zmumps_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 zmumps_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 zmumps_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 zmumps_build_panel_pos (panel_size, panel_pos, len_panel_pos, indices, npiv, npanels, nfront_or_nass, nbentries_allpanels)

Function/Subroutine Documentation

◆ zmumps_backslv_recv_and_treat()

recursive subroutine zmumps_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,
complex(kind=8), 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,
complex(kind=8), dimension( la ) a,
integer(8) la,
complex(kind=8), dimension( keep(133) ) w2,
integer myleaf_left,
integer nrhs,
integer mtype,
complex(kind=8), 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 963 of file zsol_bwd_aux.F.

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

◆ zmumps_backslv_traiter_message()

recursive subroutine zmumps_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,
complex(kind=8), 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,
complex(kind=8), dimension( la ) a,
integer(8) la,
complex(kind=8), dimension( keep(133) ) w2,
integer myleaf_left,
integer nrhs,
integer mtype,
complex(kind=8), 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 1060 of file zsol_bwd_aux.F.

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

◆ zmumps_build_panel_pos()

subroutine zmumps_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 1844 of file zsol_bwd_aux.F.

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

◆ zmumps_solve_node_bwd()

subroutine zmumps_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,
complex(kind=8), dimension( la ) a,
integer(8), intent(in) la,
integer, dimension(liw) iw,
integer, intent(in) liw,
complex(kind=8), 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,
complex(kind=8), 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,
complex(kind=8), 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,
complex(kind=8), 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 zsol_bwd_aux.F.

32 USE zmumps_ooc
33 USE zmumps_buf
34 USE zmumps_sol_lr, only : zmumps_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 COMPLEX(kind=8) :: A( LA )
57 COMPLEX(kind=8) :: W(LWC)
58 COMPLEX(kind=8) :: 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 COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS)
67 INTEGER(8), intent(in) :: LRHS_ROOT
68 COMPLEX(kind=8) 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 COMPLEX(kind=8) ALPHA,ONE,ZERO
114 parameter(zero=(0.0d0,0.0d0),
115 & one=(1.0d0,0.0d0),
116 & alpha=(-1.0d0,0.0d0))
117 LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR
118 INTEGER, EXTERNAL :: MUMPS_TYPENODE
119 INTEGER, EXTERNAL :: MUMPS_PROCNODE
120 error_was_broadcasted = .false.
121 do_mcast2_termbwd = .false.
122 no_children = .false.
123 IF (do_nbsparse) THEN
124 jbdeb= rhs_bounds(2*step(inode)-1)
125 jbfin= rhs_bounds(2*step(inode))
126 nrhs_b = jbfin-jbdeb+1
127 ELSE
128 jbdeb = 1
129 jbfin = nrhs
130 nrhs_b = nrhs
131 ENDIF
132 IF ( inode .EQ. keep( 38 ) .OR. inode .EQ. keep( 20 ) ) THEN
133 ipos = ptrist(step(inode))+keep(ixsz)
134 npiv = iw(ipos+3)
135 liell = iw(ipos) + npiv
136 ipos = ptrist(step(inode)) + 5 + keep(ixsz)
137 IF ( mtype .EQ. 1 .AND. keep(50) .EQ. 0) THEN
138 j1 = ipos + liell + 1
139 j2 = ipos + liell + npiv
140 ELSE
141 j1 = ipos + 1
142 j2 = ipos + npiv
143 END IF
144 ifr8 = 0_8
145 iposinrhscomp = posinrhscomp_bwd(iw(j1))
146 CALL zmumps_sol_cpy_fs2rhscomp(jbdeb, jbfin, j2-j1+1,
147 & keep, rhscomp, nrhs, lrhscomp, iposinrhscomp,
148 & rhs_root(1+npiv*(jbdeb-1)), npiv, 1)
149 in = inode
150 270 in = fils(in)
151 IF (in .GT. 0) GOTO 270
152 IF (in .EQ. 0) THEN
153 myleaf_left = myleaf_left - 1
154 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
155 & keep(31) .EQ. 0)
156 IF (keep(31) .NE. 0) THEN
157 IF ( .NOT. mumps_in_or_root_ssarbr(
158 & procnode_steps(step(inode)), keep(199) ) ) THEN
159 keep(31) = keep(31) - 1
160 IF (keep(31) .EQ. 1) THEN
161 allow_others_to_leave = .true.
162 ENDIF
163 ENDIF
164 ENDIF
165 IF (allow_others_to_leave) THEN
166 do_mcast2_termbwd = .true.
167 nbfinf = nbfinf - 1
168 ENDIF
169 RETURN
170 ENDIF
171 IF = -in
172 long = npiv
173 nbfils = ne_steps(step(inode))
174 IF ( prun_below ) THEN
175 i = nbfils
176 nbfils = 0
177 DO WHILE (i.GT.0)
178 IF ( to_process(step(if)) ) nbfils = nbfils+1
179 IF = frere(step(if))
180 i = i -1
181 ENDDO
182 IF (nbfils.EQ.0) THEN
183 no_children = .true.
184 ELSE
185 no_children = .false.
186 ENDIF
187 IF = -in
188 ENDIF
189 DO i = 0, slavef - 1
190 deja_send( i ) = .false.
191 END DO
192 pool_first_pos=iipool
193 DO i = 1, nbfils
194 IF ( prun_below ) THEN
195 1030 IF ( .NOT.to_process(step(if)) ) THEN
196 IF = frere(step(if))
197 GOTO 1030
198 ENDIF
199 no_children = .false.
200 ENDIF
201 IF (mumps_procnode(procnode_steps(step(if)),keep(199))
202 & .EQ. myid) THEN
203 ipool(iipool) = IF
204 iipool = iipool + 1
205 ELSE
206 procdest = mumps_procnode(procnode_steps(step(if)),
207 & keep(199))
208 IF (.NOT. deja_send( procdest )) THEN
209 600 CONTINUE
210 CALL zmumps_buf_send_vcb( nrhs_b, IF, 0, 0,
211 & long, long, iw( j1 ),
212 & rhs_root( 1+npiv*(jbdeb-1) ),
213 & jbdeb, jbfin,
214 & rhscomp(1, 1), nrhs, lrhscomp,
215 & iposinrhscomp, npiv,
216 & keep, procdest,
217 & noeud, comm, ierr )
218 IF ( ierr .EQ. -1 ) THEN
219 CALL zmumps_backslv_recv_and_treat(
220 & .false., flag,
221 & bufr, lbufr, lbufr_bytes,
222 & myid, slavef, comm,
223 & n, iwcb, liww, posiwcb,
224 & w, lwc, poswcb,
225 & iipool, nbfinf, ptricb, ptracb, info,
226 & ipool, lpool, panel_pos, lpanel_pos,
227 & step, frere, fils, procnode_steps,
228 & pleftw, keep,keep8, dkeep,
229 & ptrist, ptrfac, iw, liw, a, la, w2,
230 & myleaf_left,
231 & nrhs, mtype,
232 & rhscomp, lrhscomp, posinrhscomp_bwd,
233 & prun_below, to_process, size_to_process
234 & , from_pp
235 & )
236 IF ( info( 1 ) .LT. 0 ) THEN
237 error_was_broadcasted = .true.
238 RETURN
239 ENDIF
240 GOTO 600
241 ELSE IF ( ierr .EQ. -2 ) THEN
242 info( 1 ) = -17
243 info( 2 ) = nrhs_b * long * keep(35) +
244 & ( long + 4 ) * keep(34)
245 error_was_broadcasted = .false.
246 RETURN
247 ELSE IF ( ierr .EQ. -3 ) THEN
248 info( 1 ) = -20
249 info( 2 ) = nrhs_b * long * keep(35) +
250 & ( long + 4 ) * keep(34)
251 error_was_broadcasted = .false.
252 RETURN
253 ELSE IF ( ierr .NE. 0 ) THEN
254 WRITE(*,*) "Internal error 2 ZMUMPS_SOLVE_NODE_BWD",
255 & ierr
256 CALL mumps_abort()
257 END IF
258 deja_send( procdest ) = .true.
259 END IF
260 ENDIF
261 IF = frere(step(if))
262 ENDDO
263 allow_others_to_leave = .false.
264 IF ( prun_below .AND. no_children ) THEN
265 myleaf_left = myleaf_left - 1
266 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
267 & keep(31) .EQ. 0)
268 ENDIF
269 IF ( keep(31). ne. 0) THEN
270 IF ( .NOT. mumps_in_or_root_ssarbr(
271 & procnode_steps(step(inode)), keep(199) ) ) THEN
272 keep(31) = keep(31) - 1
273 IF (keep(31) .EQ. 1) THEN
274 allow_others_to_leave = .true.
275 ENDIF
276 ENDIF
277 ENDIF
278 IF ( allow_others_to_leave ) THEN
279 do_mcast2_termbwd = .true.
280 nbfinf = nbfinf - 1
281 ENDIF
282 IF (iipool.NE.pool_first_pos) THEN
283 DO i=1,(iipool-pool_first_pos)/2
284 tmp = ipool(pool_first_pos+i-1)
285 ipool(pool_first_pos+i-1) = ipool(iipool-i)
286 ipool(iipool-i) = tmp
287 ENDDO
288 ENDIF
289 RETURN
290 END IF
291 in_subtree = mumps_in_or_root_ssarbr(
292 & procnode_steps(step(inode)), keep(199) )
293 typenode = mumps_typenode(procnode_steps(step(inode)),
294 & keep(199))
295 ltlevel2= (
296 & (typenode .eq.2 ) .AND.
297 & (mtype.NE.1) )
298 npiv = iw(ptrist(step(inode))+2+keep(ixsz)+1)
299 IF ((npiv.NE.0).AND.(ltlevel2)) THEN
300 ipos = ptrist(step(inode)) + 2 + keep(ixsz)
301 liell = iw(ipos-2)+iw(ipos+1)
302 nelim = iw(ipos-1)
303 ipos = ipos + 1
304 npiv = iw(ipos)
305 ncb = liell - npiv - nelim
306 ipos = ipos + 2
307 nslaves = iw( ipos )
308 offset = 0
309 ipos = ipos + nslaves
310 iw(ptrist(step(inode))+xxs)= c_fini+nslaves
311 IF ( posiwcb - 2 .LT. 0 .or.
312 & poswcb-int(ncb,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
313 CALL zmumps_compso( n, keep(28), iwcb, liww, w, lwc,
314 & poswcb, posiwcb, ptricb, ptracb)
315 IF ( poswcb-int(ncb,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
316 info( 1 ) = -11
317 CALL mumps_set_ierror(ncb * nrhs_b - poswcb-pleftw+1_8,
318 & info(2))
319 error_was_broadcasted = .false.
320 RETURN
321 END IF
322 IF ( posiwcb - 2 .LT. 0 ) THEN
323 info( 1 ) = -14
324 info( 2 ) = 2 - posiwcb
325 error_was_broadcasted = .false.
326 RETURN
327 END IF
328 END IF
329 posiwcb = posiwcb - 2
330 poswcb = poswcb - int(ncb,8)*int(nrhs_b,8)
331 ptricb(step( inode )) = posiwcb + 1
332 ptracb(step( inode )) = poswcb + 1_8
333 iwcb( ptricb(step( inode )) ) = ncb*nrhs_b
334 iwcb( ptricb(step( inode )) + 1 ) = 1
335 IF ( mtype.EQ.1 .AND. keep(50).EQ.0 ) THEN
336 posindices = ipos + liell + 1
337 ELSE
338 posindices = ipos + 1
339 END IF
340 IF ( ncb.EQ.0 ) THEN
341 write(6,*) ' Internal Error type 2 node with no CB '
342 CALL mumps_abort()
343 ENDIF
344 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
345 j1 = ipos + liell + npiv + nelim +1
346 j2 = ipos + 2 * liell
347 ELSE
348 j1 = ipos + npiv + nelim +1
349 j2 = ipos + liell
350 END IF
351 ifr8 = ptracb(step( inode )) - 1_8
352 CALL zmumps_sol_bwd_gthr( jbdeb, jbfin, j1, j2,
353 & rhscomp, nrhs, lrhscomp,
354 & w(ptracb(step(inode))), ncb, 1,
355 & iw, liw, keep, n, posinrhscomp_bwd )
356 ifr8 = ifr8 + int(j2-keep(253)-j1+1,8)
357 IF (keep(252).NE.0) THEN
358 DO jj = j2-keep(253)+1, j2
359 ifr8 = ifr8 + 1_8
360 DO k=jbdeb, jbfin
361 IF (k.EQ.jj-j2+keep(253)) THEN
362 w(ifr8+int(k-jbdeb,8)*int(ncb,8)) = alpha
363 ELSE
364 w(ifr8+int(k-jbdeb,8)*int(ncb,8)) = zero
365 ENDIF
366 ENDDO
367 ENDDO
368 ENDIF
369 DO islave = 1, nslaves
370 CALL mumps_bloc2_get_slave_info(
371 & keep,keep8, inode, step, n, slavef,
372 & istep_to_iniv2, tab_pos_in_pere,
373 & islave, ncb,
374 & nslaves,
375 & effectivesize,
376 & firstindex )
377 500 CONTINUE
378 dest = iw( ptrist(step(inode))+5+islave+keep(ixsz))
379 CALL zmumps_buf_send_backvec(nrhs_b, inode,
380 & w(offset+ptracb(step(inode))),
381 & effectivesize,
382 & ncb, dest,
383 & backslv_master2slave, jbdeb, jbfin,
384 & keep, comm, ierr )
385 IF ( ierr .EQ. -1 ) THEN
386 CALL zmumps_backslv_recv_and_treat(
387 & .false., flag,
388 & bufr, lbufr, lbufr_bytes,
389 & myid, slavef, comm,
390 & n, iwcb, liww, posiwcb,
391 & w, lwc, poswcb,
392 & iipool, nbfinf, ptricb, ptracb, info,
393 & ipool, lpool, panel_pos, lpanel_pos,
394 & step, frere, fils,
395 & procnode_steps, pleftw, keep,keep8, dkeep,
396 & ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left,
397 & nrhs, mtype,
398 & rhscomp, lrhscomp, posinrhscomp_bwd,
399 & prun_below , to_process, size_to_process
400 & , from_pp
401 & )
402 IF ( info( 1 ) .LT. 0 ) THEN
403 error_was_broadcasted = .true.
404 RETURN
405 ENDIF
406 GOTO 500
407 ELSE IF ( ierr .EQ. -2 ) THEN
408 info( 1 ) = -17
409 info( 2 ) = nrhs_b * effectivesize * keep(35) +
410 & 2 * keep(34)
411 error_was_broadcasted = .false.
412 RETURN
413 ELSE IF ( ierr .EQ. -3 ) THEN
414 info( 1 ) = -20
415 info( 2 ) = nrhs_b * effectivesize * keep(35) +
416 & 2 * keep(34)
417 error_was_broadcasted = .false.
418 RETURN
419 END IF
420 offset = offset + effectivesize
421 END DO
422 iwcb( ptricb(step( inode )) + 1 ) = 0
423 CALL zmumps_freetopso(n, keep(28), iwcb, liww, w, lwc,
424 & poswcb,posiwcb,ptricb,ptracb)
425 RETURN
426 ENDIF
427 lr_activated = (iw(ptrist(step(inode))+xxlr).GT.0)
428 compress_panel = (iw(ptrist(step(inode))+xxlr).GE.2)
429 oocwrite_compatible_with_blr =
430 & (.NOT.lr_activated.OR.(.NOT.compress_panel).OR.
431 & (keep(485).EQ.0)
432 & )
433 ipos = ptrist(step(inode)) + 2 + keep(ixsz)
434 liell = iw(ipos-2)+iw(ipos+1)
435 nelim = iw(ipos-1)
436 ipos = ipos + 1
437 npiv = iw(ipos)
438 ncb = liell - npiv
439 ipos = ipos + 1
440 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr) THEN
441 CALL zmumps_solve_get_ooc_node(
442 & inode,ptrfac,keep,a,la,step,
443 & keep8,n,must_be_permuted,ierr)
444 IF(ierr.LT.0)THEN
445 info(1)=ierr
446 info(2)=0
447 error_was_broadcasted = .false.
448 RETURN
449 ENDIF
450 ENDIF
451 apos = ptrfac( step(inode))
452 nslaves = iw( ptrist(step(inode)) + 5 + keep(ixsz) )
453 ipos = ipos + 1 + nslaves
454 IF (keep(201).EQ.1.AND.oocwrite_compatible_with_blr) THEN
455 liwfac = iw(ptrist(step(inode))+xxi)
456 IF (mtype.NE.1) THEN
457 typef = typef_l
458 ELSE
459 typef = typef_u
460 ENDIF
461 panel_size = zmumps_ooc_panel_size( liell )
462 IF (keep(50).NE.1) THEN
463 CALL zmumps_ooc_pp_check_perm_freed(
464 & iw(ipos+1+2*liell),
465 & must_be_permuted )
466 ENDIF
467 ENDIF
468 long = 0
469 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
470 j1 = ipos + liell + 1
471 j2 = ipos + npiv + liell
472 ELSE
473 j1 = ipos + 1
474 j2 = ipos + npiv
475 ENDIF
476 IF (in_subtree) THEN
477 ptwcb = pleftw
478 IF ( poswcb .LT. int(liell,8)*int(nrhs_b,8) ) THEN
479 CALL zmumps_compso( n, keep(28), iwcb, liww, w, lwc,
480 & poswcb, posiwcb, ptricb, ptracb)
481 IF ( poswcb .LT. int(liell,8)*int(nrhs_b,8) ) THEN
482 info(1) = -11
483 CALL mumps_set_ierror(int(liell,8)*int(nrhs_b,8)-poswcb,
484 & info(2))
485 error_was_broadcasted = .false.
486 RETURN
487 END IF
488 END IF
489 ELSE
490 IF ( posiwcb - 2 .LT. 0 .or.
491 & poswcb-int(liell,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
492 CALL zmumps_compso( n, keep(28), iwcb, liww, w, lwc,
493 & poswcb, posiwcb, ptricb, ptracb )
494 IF ( poswcb-int(liell,8)*int(nrhs_b,8) .LT. pleftw-1_8 ) THEN
495 info( 1 ) = -11
496 CALL mumps_set_ierror( int(liell,8)*int(nrhs_b,8)-
497 & poswcb-pleftw+1_8,
498 & info(2) )
499 error_was_broadcasted = .false.
500 RETURN
501 END IF
502 IF ( posiwcb - 2 .LT. 0 ) THEN
503 info( 1 ) = -14
504 info( 2 ) = 2 - posiwcb
505 error_was_broadcasted = .false.
506 RETURN
507 END IF
508 END IF
509 posiwcb = posiwcb - 2
510 poswcb = poswcb - int(liell,8)*int(nrhs_b,8)
511 ptricb(step( inode )) = posiwcb + 1
512 ptracb(step( inode )) = poswcb + 1_8
513 iwcb( ptricb(step( inode )) ) = liell*nrhs_b
514 iwcb( ptricb(step( inode )) + 1 ) = 1
515 IF ( mtype.EQ.1 .AND. keep(50).EQ.0 ) THEN
516 posindices = ipos + liell + 1
517 ELSE
518 posindices = ipos + 1
519 END IF
520 ptwcb = ptracb(step( inode ))
521 ENDIF
522 IF (j2.GE.j1) THEN
523 iposinrhscomp = posinrhscomp_bwd(iw(j1))
524 ELSE
525 iposinrhscomp = -99999
526 ENDIF
527 IF (j2.GE.j1) THEN
528 DO k=jbdeb, jbfin
529 IF (keep(252).NE.0) THEN
530 DO jj = j1, j2
531 rhscomp(iposinrhscomp+jj-j1,k) = zero
532 ENDDO
533 ENDIF
534 END DO
535 ENDIF
536 ifr8 = ptwcb + int(npiv - 1,8)
537 IF ( liell .GT. npiv ) THEN
538 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0 ) THEN
539 j1 = ipos + liell + npiv + 1
540 j2 = ipos + 2 * liell
541 ELSE
542 j1 = ipos + npiv + 1
543 j2 = ipos + liell
544 END IF
545 CALL zmumps_sol_bwd_gthr( jbdeb, jbfin, j1, j2,
546 & rhscomp, nrhs, lrhscomp,
547 & w(ptwcb), liell, npiv+1,
548 & iw, liw, keep, n, posinrhscomp_bwd )
549 ifr8 = ifr8 + int(j2-keep(253)-j1+1,8)
550 IF (keep(252).NE.0) THEN
551 DO jj = j2-keep(253)+1, j2
552 ifr8 = ifr8 + 1_8
553 DO k=jbdeb, jbfin
554 IF (k.EQ.jj-j2+keep(253)) THEN
555 w(ifr8+int(k-jbdeb,8)*int(liell,8)) = alpha
556 ELSE
557 w(ifr8+int(k-jbdeb,8)*int(liell,8)) = zero
558 ENDIF
559 ENDDO
560 ENDDO
561 ENDIF
562 ncb = liell - npiv
563 IF (npiv .EQ. 0) GOTO 160
564 ENDIF
565 IF (keep(201).EQ.1.AND.oocwrite_compatible_with_blr) THEN
566 j = npiv / panel_size
567 twobytwo = keep(50).EQ.2 .AND.
568 & ((typenode.EQ.1.AND.keep(103).GT.0) .OR.
569 & (typenode.EQ.2.AND.keep(105).GT.0))
570 IF (twobytwo) THEN
571 CALL zmumps_build_panel_pos(panel_size, panel_pos, lpanel_pos,
572 & iw(ipos+1+liell), npiv, npanels, liell,
573 & nbentries_allpanels)
574 ELSE
575 IF (npiv.EQ.j*panel_size) THEN
576 npiv_last = npiv
577 nbjlast = panel_size
578 npanels = j
579 ELSE
580 npiv_last = (j+1)* panel_size
581 nbjlast = npiv-j*panel_size
582 npanels = j+1
583 ENDIF
584 nbentries_allpanels =
585 & int(liell,8) * int(npiv,8)
586 & - int( ( j * ( j - 1 ) ) /2,8 )
587 & * int(panel_size,8) * int(panel_size,8)
588 & - int(j,8)
589 & * int(mod(npiv, panel_size),8)
590 & * int(panel_size,8)
591 jj=npiv_last
592 ENDIF
593 aposdeb = apos + nbentries_allpanels
594 DO ipanel = npanels, 1, -1
595 IF (twobytwo) THEN
596 nbj = panel_pos(ipanel+1)-panel_pos(ipanel)
597 beg_panel = panel_pos(ipanel)
598 ELSE
599 IF (jj.EQ.npiv_last) THEN
600 nbj = nbjlast
601 ELSE
602 nbj = panel_size
603 ENDIF
604 beg_panel = jj- panel_size+1
605 ENDIF
606 ldaj = liell-beg_panel+1
607 aposdeb = aposdeb - int(nbj,8)*int(ldaj,8)
608 ptwcb_panel = ptwcb + int(beg_panel - 1,8)
609 iposinrhscomp_panel = iposinrhscomp + beg_panel - 1
610 ncb_panel = ldaj - nbj
611 IF (keep(50).NE.1.AND.must_be_permuted) THEN
612 CALL zmumps_get_ooc_perm_ptr(typef, tmp_nbpanels,
613 & i_pivrptr, i_pivr, ipos + 1 + 2 * liell, iw, liw)
614 IF (npiv.EQ.(iw(i_pivrptr)-1)) THEN
615 must_be_permuted=.false.
616 ELSE
617 CALL zmumps_permute_panel(
618 & iw(i_pivr + iw(i_pivrptr+ipanel-1)-iw(i_pivrptr)),
619 & npiv-iw(i_pivrptr+ipanel-1)+1,
620 & iw(i_pivrptr+ipanel-1)-1,
621 & a(aposdeb),
622 & ldaj, nbj, beg_panel-1)
623 ENDIF
624 ENDIF
625#if defined(MUMPS_USE_BLAS2)
626 IF ( nrhs_b == 1 ) THEN
627 IF (ncb_panel.NE.0) THEN
628 IF (ncb_panel - ncb.NE. 0) THEN
629 CALL zgemv( 'T', ncb_panel-ncb, nbj, alpha,
630 & a( aposdeb + int(nbj,8) ), ldaj,
631 & rhscomp(iposinrhscomp_panel+nbj,jbdeb),
632 & 1, one,
633 & rhscomp(iposinrhscomp_panel,jbdeb), 1 )
634 ENDIF
635 IF (ncb .NE. 0) THEN
636 CALL zgemv( 'T', ncb, nbj, alpha,
637 & a( aposdeb + int(ldaj-ncb,8) ), ldaj,
638 & w( ptwcb + int(npiv,8) ),
639 & 1, one,
640 & rhscomp(iposinrhscomp_panel,jbdeb), 1 )
641 ENDIF
642 ENDIF
643 IF (mtype.NE.1) THEN
644 CALL ztrsv('L','T','U', nbj, a(aposdeb), ldaj,
645 & rhscomp(iposinrhscomp_panel,jbdeb), 1)
646 ELSE
647 CALL ztrsv('L','T','N', nbj, a(aposdeb), ldaj,
648 & rhscomp(iposinrhscomp_panel,jbdeb), 1)
649 ENDIF
650 ELSE
651#endif
652 IF (ncb_panel.NE.0) THEN
653 IF (ncb_panel - ncb .NE. 0) THEN
654 CALL zgemm( 'T', 'N', nbj, nrhs_b,
655 & ncb_panel-ncb, alpha,
656 & a(aposdeb +int(nbj,8)), ldaj,
657 & rhscomp(iposinrhscomp_panel+nbj,jbdeb), lrhscomp,
658 & one, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
659 ENDIF
660 IF (ncb .NE. 0) THEN
661 CALL zgemm( 'T', 'N', nbj, nrhs_b, ncb, alpha,
662 & a(aposdeb +int(ldaj-ncb,8)), ldaj,
663 & w( ptwcb+int(npiv,8) ), liell,
664 & one, rhscomp(iposinrhscomp_panel,jbdeb),lrhscomp)
665 ENDIF
666 ENDIF
667 IF (mtype.NE.1) THEN
668 CALL ztrsm('L','L','T','U',nbj, nrhs_b, one,
669 & a(aposdeb),
670 & ldaj, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
671 ELSE
672 CALL ztrsm('L','L','T','N',nbj, nrhs_b, one,
673 & a(aposdeb),
674 & ldaj, rhscomp(iposinrhscomp_panel,jbdeb), lrhscomp)
675 ENDIF
676#if defined(MUMPS_USE_BLAS2)
677 ENDIF
678#endif
679 IF (.NOT. twobytwo) jj=beg_panel-1
680 ENDDO
681 ELSE
682 IF ( iw(ptrist(step(inode))+xxlr) .GE. 2
683 & .AND. keep(485) .EQ. 1 ) THEN
684 iwhdlr = iw(ptrist(step(inode))+xxf)
685 CALL zmumps_sol_bwd_lr_su (
686 & inode, iwhdlr, npiv, nslaves,
687 & liell, w, lwc, nrhs_b, ptwcb,
688 & rhscomp, lrhscomp, nrhs,
689 & iposinrhscomp, jbdeb,
690 & mtype, keep, keep8,
691 & info(1), info(2) )
692 IF (info(1).LT.0) THEN
693 error_was_broadcasted = .false.
694 RETURN
695 ENDIF
696 ELSE
697 IF ( liell .GT. npiv ) THEN
698#if defined(LDLTPANEL_DEBUG)
699 WRITE(*,*) 'before gemm LIELL, NPIV, PTWCB=',liell,npiv,ptwcb
700 WRITE(*,*) 'before gemm RHSCOMP=',
701 & rhscomp(iposinrhscomp:iposinrhscomp+npiv-1,1)
702 WRITE(*,*) 'before gemm W',
703 & w(ptwcb+npiv:ptwcb+liell-1)
704 CALL mumps_geti8(ist, iw(ptrist(step(inode))+xxr))
705 WRITE(*,*) "FACTORS=",a(apos:apos+ist-1)
706#endif
707 IF ( mtype .eq. 1 ) THEN
708 ist = apos + int(npiv,8)
709#if defined(MUMPS_USE_BLAS2)
710 IF (nrhs_b == 1) THEN
711 CALL zgemv( 'T', ncb, npiv, alpha, a(ist), liell,
712 & w(ptwcb+int(npiv,8)), 1,
713 & one,
714 & rhscomp(iposinrhscomp,jbdeb), 1 )
715 ELSE
716#endif
717 CALL zgemm('T','N', npiv, nrhs_b, ncb, alpha,
718 & a(ist),
719 & liell, w(ptwcb+int(npiv,8)), liell, one,
720 & rhscomp(iposinrhscomp,jbdeb), lrhscomp)
721#if defined(MUMPS_USE_BLAS2)
722 ENDIF
723#endif
724 ELSE
725 IF ( keep(50) .eq. 0 ) THEN
726 ist = apos + int(npiv,8) * int(liell,8)
727 ELSE
728 IF( keep(459) .GT. 1) THEN
729 CALL mumps_geti8(ist, iw(ptrist(step(inode))+xxr))
730 ist = apos + ist - int(npiv,8) * int(liell-npiv,8)
731 ELSE
732 ist = apos + int(npiv,8) * int(npiv,8)
733 ENDIF
734 END IF
735#if defined(MUMPS_USE_BLAS2)
736 IF ( nrhs_b == 1 ) THEN
737 CALL zgemv( 'N', npiv, ncb, alpha, a( ist ), npiv,
738 & w( ptwcb + int(npiv,8) ),
739 & 1, one,
740 & rhscomp(iposinrhscomp,jbdeb), 1 )
741 ELSE
742#endif
743 CALL zgemm( 'N', 'N', npiv, nrhs_b, ncb, alpha,
744 & a(ist),
745 & npiv, w(ptwcb+int(npiv,8)), liell,
746 & one, rhscomp(iposinrhscomp,jbdeb), lrhscomp)
747#if defined(MUMPS_USE_BLAS2)
748 END IF
749#endif
750 END IF
751 ENDIF
752 IF ( mtype .eq. 1 ) THEN
753 ldaj = liell
754 ELSE
755 IF ( keep(50) .EQ. 0 ) THEN
756 ldaj=liell
757 ELSE
758 IF (keep(459).GT.1) THEN
759 ldaj=-999799
760 ELSE
761 ldaj=npiv
762 ENDIF
763 ENDIF
764 END IF
765 ppiv_courant = int(jbdeb-1,8)*int(lrhscomp,8)
766 & + int(iposinrhscomp,8)
767 IF (keep(459).GT.1 .AND. keep(50).NE.0) THEN
768 CALL zmumps_solve_bwd_panels( a, la, apos,
769 & npiv, iw(ipos+1+liell),
770 & nrhs_b, rhscomp(1,1), keep8(25), lrhscomp, ppiv_courant,
771 & mtype, keep )
772 ELSE
773 CALL zmumps_solve_bwd_trsolve( a, la, apos,
774 & npiv, ldaj,
775 & nrhs_b, rhscomp(1,1), keep8(25), lrhscomp, ppiv_courant,
776 & mtype, keep )
777 ENDIF
778 ENDIF
779 ENDIF
780 IF ( mtype .EQ. 1 .AND. keep(50).EQ.0) THEN
781 j1 = ipos + liell + 1
782 ELSE
783 j1 = ipos + 1
784 END IF
785 iposinrhscomp = posinrhscomp_bwd(iw(j1))
786 160 CONTINUE
787 IF (keep(201).GT.0.AND.oocwrite_compatible_with_blr) THEN
788 CALL zmumps_free_factors_for_solve(inode,ptrfac,keep(28),
789 & a,la,.true.,ierr)
790 IF(ierr.LT.0)THEN
791 info(1)=ierr
792 info(2)=0
793 error_was_broadcasted = .false.
794 RETURN
795 ENDIF
796 ENDIF
797 in = inode
798 170 in = fils(in)
799 IF (in .GT. 0) GOTO 170
800 IF (in .EQ. 0) THEN
801 myleaf_left = myleaf_left - 1
802 IF (.NOT. in_subtree ) THEN
803 iwcb(ptricb(step(inode))+1) = iwcb(ptricb(step(inode))+1)-1
804 CALL zmumps_freetopso(n, keep(28), iwcb, liww,
805 & w, lwc,
806 & poswcb,posiwcb,ptricb,ptracb)
807 ENDIF
808 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
809 & keep(31) .EQ. 0)
810 IF ( keep(31) .NE. 0 .AND.
811 & .NOT. in_subtree ) THEN
812 keep(31) = keep(31) - 1
813 IF (keep(31).EQ. 1) THEN
814 allow_others_to_leave = .true.
815 ENDIF
816 ENDIF
817 IF (allow_others_to_leave) THEN
818 do_mcast2_termbwd = .true.
819 nbfinf = nbfinf - 1
820 ENDIF
821 RETURN
822 ENDIF
823 IF = -in
824 nbfils = ne_steps(step(inode))
825 IF ( prun_below ) THEN
826 i = nbfils
827 nbfils = 0
828 DO WHILE (i.GT.0)
829 IF ( to_process(step(if)) ) nbfils = nbfils+1
830 IF = frere(step(if))
831 i = i -1
832 ENDDO
833 IF (nbfils.EQ.0) THEN
834 no_children = .true.
835 ELSE
836 no_children = .false.
837 ENDIF
838 IF = -in
839 ENDIF
840 IF (in_subtree) THEN
841 DO i = 1, nbfils
842 IF ( prun_below ) THEN
843 1010 CONTINUE
844 IF ( .NOT.to_process(step(if)) ) THEN
845 IF = frere(step(if))
846 GOTO 1010
847 ENDIF
848 no_children = .false.
849 ENDIF
850 ipool((iipool-i+1)+nbfils-i) = IF
851 iipool = iipool + 1
852 IF = frere(step(if))
853 ENDDO
854 IF (prun_below .AND. no_children) THEN
855 myleaf_left = myleaf_left - 1
856 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
857 & keep(31) .EQ. 0)
858 IF (allow_others_to_leave ) THEN
859 do_mcast2_termbwd = .true.
860 nbfinf = nbfinf - 1
861 RETURN
862 ENDIF
863 ENDIF
864 ELSE
865 DO i = 0, slavef - 1
866 deja_send( i ) = .false.
867 END DO
868 pool_first_pos=iipool
869 DO 190 i = 1, nbfils
870 IF ( prun_below ) THEN
8711020 IF ( .NOT.to_process(step(if)) ) THEN
872 IF = frere(step(if))
873 GOTO 1020
874 ENDIF
875 no_children = .false.
876 ENDIF
877 IF (mumps_procnode(procnode_steps(step(if)),
878 & keep(199)) .EQ. myid) THEN
879 ipool(iipool) = IF
880 iipool = iipool + 1
881 IF = frere(step(if))
882 ELSE
883 procdest = mumps_procnode(procnode_steps(step(if)),
884 & keep(199))
885 IF (.not. deja_send( procdest )) THEN
886 400 CONTINUE
887 CALL zmumps_buf_send_vcb( nrhs_b, IF, 0, 0,
888 & liell, liell - keep(253),
889 & iw( posindices ),
890 & w( ptracb(step(inode)) ), jbdeb, jbfin,
891 & rhscomp(1, 1), nrhs, lrhscomp,
892 & iposinrhscomp, npiv,
893 & keep, procdest, noeud, comm, ierr )
894 IF ( ierr .EQ. -1 ) THEN
895 CALL zmumps_backslv_recv_and_treat(
896 & .false., flag,
897 & bufr, lbufr, lbufr_bytes,
898 & myid, slavef, comm,
899 & n, iwcb, liww, posiwcb,
900 & w, lwc, poswcb,
901 & iipool, nbfinf, ptricb, ptracb, info,
902 & ipool, lpool, panel_pos, lpanel_pos,
903 & step, frere, fils, procnode_steps,
904 & pleftw, keep, keep8, dkeep,
905 & ptrist, ptrfac, iw, liw, a, la, w2, myleaf_left,
906 & nrhs, mtype,
907 & rhscomp, lrhscomp, posinrhscomp_bwd,
908 & prun_below, to_process, size_to_process
909 & , from_pp
910 & )
911 IF ( info( 1 ) .LT. 0 ) THEN
912 error_was_broadcasted = .true.
913 RETURN
914 ENDIF
915 GOTO 400
916 ELSE IF ( ierr .EQ. -2 ) THEN
917 info( 1 ) = -17
918 info( 2 ) = nrhs_b * liell * keep(35) + 4 * keep(34)
919 error_was_broadcasted = .false.
920 RETURN
921 ELSE IF ( ierr .EQ. -3 ) THEN
922 info( 1 ) = -20
923 info( 2 ) = nrhs_b * liell * keep(35) + 4 * keep(34)
924 error_was_broadcasted = .false.
925 RETURN
926 END IF
927 deja_send( procdest ) = .true.
928 END IF
929 IF = frere(step(if))
930 ENDIF
931 190 CONTINUE
932 IF ( prun_below .AND. no_children ) THEN
933 myleaf_left = myleaf_left - 1
934 allow_others_to_leave = ( myleaf_left .EQ. 0 .AND.
935 & keep(31) .EQ. 0)
936 IF ( allow_others_to_leave ) THEN
937 do_mcast2_termbwd = .true.
938 nbfinf = nbfinf - 1
939 RETURN
940 ENDIF
941 ENDIF
942 DO i=1,(iipool-pool_first_pos)/2
943 tmp=ipool(pool_first_pos+i-1)
944 ipool(pool_first_pos+i-1)=ipool(iipool-i)
945 ipool(iipool-i)=tmp
946 ENDDO
947 IF ( keep(31) .NE. 0 )
948 & THEN
949 keep(31) = keep(31) - 1
950 allow_others_to_leave = (keep(31) .EQ. 1)
951 IF (allow_others_to_leave) THEN
952 do_mcast2_termbwd = .true.
953 nbfinf = nbfinf - 1
954 ENDIF
955 ENDIF
956 iwcb(ptricb(step(inode))+1) = iwcb(ptricb(step(inode))+1)-1
957 CALL zmumps_freetopso(n, keep(28), iwcb, liww,
958 & w, lwc,
959 & poswcb,posiwcb,ptricb,ptracb)
960 ENDIF
961 RETURN
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
mumps_typenode
integer function mumps_typenode(procinfo_inode, k199)
Definition tools_common.F:90
zmumps_sol_cpy_fs2rhscomp
subroutine zmumps_sol_cpy_fs2rhscomp(jbdeb, jbfin, nbrows, keep, rhscomp, nrhs, lrhscomp, first_row_rhscomp, w, ld_w, first_row_w)
Definition zsol_aux.F:1041