OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dsol_c.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, University of Bordeaux.
8C
9C This version of MUMPS is provided to you free of charge. It is
10C released under the CeCILL-C license
11C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 SUBROUTINE dmumps_sol_c(root, N, A, LA, IW, LIW, W, LWC,
15 & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP,
16 & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB,
17 & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP,
18 & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES,
19 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF,
20 & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT,
21 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, POSINRHSCOMP_BWD,
22 & NZ_RHS, NBCOL_INBLOC, NRHS_ORIG, JBEG_RHS, Step2node, LStep2node,
23 & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS,
24 & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSCOMP_F,
25 & NB_FS_IN_RHSCOMP_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS
26 & ,IPOOL_B_L0_OMP, LPOOL_B_L0_OMP, IPOOL_A_L0_OMP, LPOOL_A_L0_OMP,
27 & L_VIRT_L0_OMP, VIRT_L0_OMP, L_PHYS_L0_OMP, PHYS_L0_OMP,
28 & PERM_L0_OMP, PTR_LEAFS_L0_OMP, L0_OMP_MAPPING, LL0_OMP_MAPPING,
29 & L0_OMP_FACTORS, LL0_OMP_FACTORS
30 & )
31 USE dmumps_ooc
32 USE dmumps_sol_es
33 USE dmumps_sol_l0omp_m, ONLY : dmumps_sol_l0omp_r,
34 & dmumps_sol_l0omp_s
35 USE dmumps_struc_def, ONLY : dmumps_root_struc
36 & , dmumps_l0ompfac_t
37 IMPLICIT NONE
38#if defined(V_T)
39 include 'VT.inc'
40#endif
41 TYPE ( DMUMPS_ROOT_STRUC ) :: root
42 INTEGER(8) :: LA
43 INTEGER(8) :: LWC
44 INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA
45 INTEGER ICNTL(60),INFO(80), KEEP(500)
46 DOUBLE PRECISION, intent(inout) :: DKEEP(230)
47 INTEGER(8) KEEP8(150)
48 INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW)
49 INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)),
50 & DAD(KEEP(28))
51 INTEGER(8) :: PTRFAC(KEEP(28))
52 INTEGER :: LIWK_PTRACB
53 INTEGER(8) :: PTRACB(LIWK_PTRACB)
54 INTEGER NRHS, LRHSCOMP, NB_FS_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT
55 DOUBLE PRECISION A(LA), W(LWC),
56 & W2(KEEP(133))
57 DOUBLE PRECISION :: RHSCOMP(LRHSCOMP,NRHS)
58 INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES
59 INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP_FWD(N),
60 & posinrhscomp_bwd(n)
61 INTEGER LBUFR, LBUFR_BYTES
62 INTEGER BUFR(LBUFR)
63 INTEGER ISTEP_TO_INIV2(KEEP(71)),
64 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
65 INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1
66 INTEGER SIZE_ROOT, MASTER_ROOT
67 INTEGER(8) :: LRHS_ROOT
68 DOUBLE PRECISION RHS_ROOT(LRHS_ROOT)
69 LOGICAL, intent(in) :: FROM_PP
70 INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC, NRHS_ORIG
71 INTEGER, intent(in) :: SIZE_UNS_PERM_INV
72 INTEGER, intent(in) :: SIZE_PERM_RHS
73 INTEGER, intent(in) :: JBEG_RHS
74 INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS)
75 INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1)
76 INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS)
77 INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV)
78 INTEGER, intent(in) :: LStep2node
79 INTEGER, intent(in) :: Step2node(LStep2node)
80 LOGICAL, intent(in) :: DO_NBSPARSE
81 INTEGER, intent(in) :: LRHS_BOUNDS
82 INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS)
83 INTEGER, INTENT (IN) :: LPOOL_B_L0_OMP
84 INTEGER, INTENT (IN) :: IPOOL_B_L0_OMP( LPOOL_B_L0_OMP )
85 INTEGER, INTENT (IN) :: LPOOL_A_L0_OMP
86 INTEGER, INTENT (IN) :: IPOOL_A_L0_OMP( LPOOL_A_L0_OMP )
87 INTEGER, INTENT (IN) :: L_PHYS_L0_OMP
88 INTEGER, INTENT (INOUT) :: PHYS_L0_OMP( L_PHYS_L0_OMP )
89 INTEGER, INTENT (IN) :: L_VIRT_L0_OMP
90 INTEGER, INTENT (IN) :: VIRT_L0_OMP( L_VIRT_L0_OMP )
91 INTEGER, INTENT (IN) :: PERM_L0_OMP( L_PHYS_L0_OMP )
92 INTEGER, INTENT (IN) :: PTR_LEAFS_L0_OMP( L_PHYS_L0_OMP + 1)
93 INTEGER, INTENT (IN) :: LL0_OMP_MAPPING
94 INTEGER, INTENT (IN) :: L0_OMP_MAPPING( LL0_OMP_MAPPING )
95 INTEGER, INTENT (IN) :: LL0_OMP_FACTORS
96 TYPE (DMUMPS_L0OMPFAC_T), INTENT(IN) ::
97 & l0_omp_factors(ll0_omp_factors)
98 INTEGER MP, LP, LDIAG
99 INTEGER K,I,II
100 INTEGER allocok
101 INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS
102 INTEGER MYLEAF_NOT_PRUNED
103 INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB
104 INTEGER MTYPE_LOC
105 INTEGER MODE_RHS_BOUNDS
106 INTEGER IERR
107 INTEGER(8) :: IAPOS
108 INTEGER IOLDPS,
109 & local_m,
110 & local_n
111#if defined(V_T)
112 INTEGER soln_c_class, forw_soln, back_soln, root_soln
113#endif
114 LOGICAL DOFORWARD, DOROOT, DOBACKWARD
115 LOGICAL :: DO_L0OMP_FWD, DO_L0OMP_BWD
116 LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED
117 INTEGER IROOT
118 LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL
119 LOGICAL SWITCH_OFF_ES
120 LOGICAL DUMMY_BOOL
121 INTEGER :: IDUMMY
122 INTEGER :: NBROOT_UNDER_L0
123 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0d0
124 include 'mumps_headers.h'
125 INTEGER, DIMENSION(:), ALLOCATABLE :: nodes_RHS
126 INTEGER nb_nodes_RHS
127 INTEGER nb_prun_leaves
128 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves
129 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List
130 INTEGER nb_prun_nodes
131 INTEGER nb_prun_roots, JAM1
132 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots
133 INTEGER :: SIZE_TO_PROCESS
134 LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS
135 INTEGER ISTEP, INODE_PRINC
136 INTEGER :: INODE, ICHILD
137 LOGICAL AM1, DO_PRUN
138 LOGICAL Exploit_Sparsity
139 LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD
140 INTEGER :: OOC_FCT_TYPE_TMP
141 INTEGER :: MUMPS_OOC_GET_FCT_TYPE
142 EXTERNAL :: mumps_ooc_get_fct_type
143 DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot
144 INTEGER :: nb_sparse
145 INTEGER, EXTERNAL :: MUMPS_PROCNODE
146 LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR
147 myleaf = -1
148 lp = icntl(1)
149 mp = icntl(2)
150 ldiag = icntl(4)
151#if defined(V_T)
152 CALL vtclassdef( 'Soln_c',soln_c_class,ierr)
153 CALL vtfuncdef( 'forw_soln',soln_c_class,forw_soln,ierr)
154 CALL vtfuncdef( 'back_soln',soln_c_class,back_soln,ierr)
155 CALL vtfuncdef( 'root_soln',soln_c_class,root_soln,ierr)
156#endif
157 IF (.NOT. from_pp) THEN
158 CALL mumps_secdeb(time_fwd)
159 ENDIF
160 nstk_s = 1
161 ptricb = nstk_s + keep(28)
162 ipool = ptricb + keep(28)
163 lpool = na(1) + 1
164 ipanel_pos = ipool + lpool
165 IF (keep(201).EQ.1) THEN
166 lpanel_pos = keep(228)+1
167 ELSE
168 lpanel_pos = 1
169 ENDIF
170 IF (ipanel_pos + lpanel_pos -1 .ne. liw1 ) THEN
171 WRITE(*,*) myid, ": internal error 1 in dmumps_sol_c",
172 & IPANEL_POS, LPANEL_POS, LIW1
173 CALL MUMPS_ABORT()
174 ENDIF
175 DOFORWARD = .TRUE.
176 DOBACKWARD= .TRUE.
177 SPECIAL_ROOT_REACHED = .TRUE.
178 SWITCH_OFF_ES = .FALSE.
179.NE..OR..NE. IF ( KEEP(111)0 KEEP(252)0 ) THEN
180 DOFORWARD = .FALSE.
181 ENDIF
182.eq. IF (KEEP(221)1) DOBACKWARD = .FALSE.
183.eq. IF (KEEP(221)2) DOFORWARD = .FALSE.
184.EQ..AND. IF ( KEEP(60)0
185 & (
186.NE..AND. & (KEEP(38)0 root%yes)
187.OR. &
188.NE..AND..EQ. & (KEEP(20)0 MYID_NODESMASTER_ROOT)
189 & )
190.AND..EQ. & KEEP(252)0
191 & )
192 &THEN
193 DOROOT = .TRUE.
194 ELSE
195 DOROOT = .FALSE.
196 ENDIF
197.AND..NE..AND..EQ. DOROOT_BWD_PANEL = DOROOT MTYPE1 KEEP(50)0
198.AND..EQ. & KEEP(201)1
199.AND..NOT. DOROOT_FWD_OOC = DOROOT DOROOT_BWD_PANEL
200.NE. AM1 = (KEEP(237) 0)
201.NE..AND..NOT. Exploit_Sparsity = (KEEP(235) 0) ( AM1)
202.OR. DO_PRUN = (Exploit_SparsityAM1)
203 IF (FROM_PP) THEN
204 Exploit_Sparsity = .FALSE.
205 DO_PRUN = .FALSE.
206 IF ( AM1 ) THEN
207 WRITE(*,*) "internal error 2 in dmumps_sol_c"
208 CALL MUMPS_ABORT()
209 ENDIF
210 ENDIF
211.GT..AND..GT. DO_L0OMP_FWD= ( (KEEP(401)0)(KEEP(400)0)
212.AND. & DOFORWARD )
213.AND..EQ. DO_L0OMP_FWD = DO_L0OMP_FWD KEEP(201)0
214.GT..AND..GT. DO_L0OMP_BWD = ( (KEEP(401)0)(KEEP(400)0)
215.AND. & DOBACKWARD )
216.AND..EQ. DO_L0OMP_BWD = DO_L0OMP_BWD KEEP(201)0
217 IF ( DO_PRUN ) THEN
218 ALLOCATE (Pruned_SONS(KEEP(28)), stat=I)
219.GT. IF(I0) THEN
220 INFO(1)=-13
221 INFO(2)=KEEP(28)
222 END IF
223 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
224.LT. IF(INFO(1)0) GOTO 500
225 ENDIF
226 IF ( DO_PRUN
227.OR. & DO_L0OMP_BWD
228 & ) THEN
229 SIZE_TO_PROCESS = KEEP(28)
230 ELSE
231 SIZE_TO_PROCESS = 1
232 ENDIF
233 ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I)
234.GT. IF(I0) THEN
235 INFO(1)=-13
236 INFO(2)=KEEP(28)
237 END IF
238 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
239.LT. IF(INFO(1)0) GOTO 500
240.AND. IF ( DOFORWARD DO_PRUN ) THEN
241 nb_prun_nodes = 0
242 nb_prun_roots = 0
243 Pruned_SONS(:) = -1
244 IF ( Exploit_Sparsity ) THEN
245 nb_nodes_RHS = 0
246 DO I = 1, NZ_RHS
247 ISTEP = abs( STEP(IRHS_SPARSE(I)) )
248 INODE_PRINC = Step2node( ISTEP )
249.eq. IF ( Pruned_SONS(ISTEP) -1) THEN
250 nb_nodes_RHS = nb_nodes_RHS +1
251 Pruned_SONS(ISTEP) = 0
252 ENDIF
253 ENDDO
254 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok)
255.GT. IF(allocok0) THEN
256 INFO(1)=-13
257 INFO(2)=nb_nodes_RHS
258 END IF
259 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
260.LT. IF(INFO(1)0) GOTO 500
261 nb_nodes_RHS = 0
262 Pruned_SONS = -1
263 DO I = 1, NZ_RHS
264 ISTEP = abs( STEP(IRHS_SPARSE(I)) )
265 INODE_PRINC = Step2node( ISTEP )
266.eq. IF ( Pruned_SONS(ISTEP) -1) THEN
267 nb_nodes_RHS = nb_nodes_RHS +1
268 nodes_RHS(nb_nodes_RHS) = INODE_PRINC
269 Pruned_SONS(ISTEP) = 0
270 ENDIF
271 ENDDO
272 ELSE IF ( AM1 ) THEN
273 nb_nodes_RHS = 0
274 DO I = 1, NBCOL_INBLOC
275.EQ. IF ( (IRHS_PTR(I+1)-IRHS_PTR(I))0) CYCLE
276.NE..OR..NE. IF ( (KEEP(242) 0 ) (KEEP(243)0) ) THEN
277 JAM1 = PERM_RHS(JBEG_RHS+I-1)
278 ELSE
279 JAM1 = JBEG_RHS+I-1
280 ENDIF
281 ISTEP = abs(STEP(JAM1))
282 INODE_PRINC = Step2node(ISTEP)
283.eq. IF ( Pruned_SONS(ISTEP) -1) THEN
284 nb_nodes_RHS = nb_nodes_RHS +1
285 Pruned_SONS(ISTEP) = 0
286 ENDIF
287 ENDDO
288 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok)
289.GT. IF(allocok0) THEN
290 INFO(1)=-13
291 INFO(2)=nb_nodes_RHS
292 END IF
293 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
294.LT. IF(INFO(1)0) GOTO 500
295 nb_nodes_RHS = 0
296 Pruned_SONS = -1
297 DO I = 1, NBCOL_INBLOC
298.EQ. IF ( (IRHS_PTR(I+1)-IRHS_PTR(I))0) CYCLE
299.NE..OR..NE. IF ( (KEEP(242) 0 ) (KEEP(243)0) ) THEN
300 JAM1 = PERM_RHS(JBEG_RHS+I-1)
301 ELSE
302 JAM1 = JBEG_RHS+I-1
303 ENDIF
304 ISTEP = abs(STEP(JAM1))
305 INODE_PRINC = Step2node(ISTEP)
306.eq. IF ( Pruned_SONS(ISTEP) -1) THEN
307 nb_nodes_RHS = nb_nodes_RHS +1
308 nodes_RHS(nb_nodes_RHS) = INODE_PRINC
309 Pruned_SONS(ISTEP) = 0
310 ENDIF
311 ENDDO
312 ENDIF
313 CALL DMUMPS_CHAIN_PRUN_NODES(
314 & .FALSE.,
315 & DAD, KEEP(28),
316 & STEP, N,
317 & nodes_RHS, nb_nodes_RHS,
318 & Pruned_SONS, TO_PROCESS,
319 & nb_prun_nodes, nb_prun_roots,
320 & nb_prun_leaves )
321 ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok)
322.GT. IF(allocok0) THEN
323 INFO(1)=-13
324 INFO(2)=nb_prun_nodes
325 END IF
326 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
327.LT. IF(INFO(1)0) GOTO 500
328 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok)
329.GT. IF(allocok0) THEN
330 INFO(1)=-13
331 INFO(2)=nb_prun_roots
332 END IF
333 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
334.LT. IF(INFO(1)0) GOTO 500
335 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok)
336.GT. IF(allocok0) THEN
337 INFO(1)=-13
338 INFO(2)=nb_prun_leaves
339 END IF
340 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
341.LT. IF(INFO(1)0) GOTO 500
342 CALL DMUMPS_CHAIN_PRUN_NODES(
343 & .TRUE.,
344 & DAD, KEEP(28),
345 & STEP, N,
346 & nodes_RHS, nb_nodes_RHS,
347 & Pruned_SONS, TO_PROCESS,
348 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves,
349 & Pruned_List, Pruned_Roots, Pruned_Leaves )
350 IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS)
351 CALL DMUMPS_OOC_SET_STATES_ES(N,
352 & KEEP(201), Pruned_List, nb_prun_nodes,
353 & STEP)
354.GT. IF ( KEEP(201) 0) THEN
355 OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE
356 & ('F',MTYPE,KEEP(201),KEEP(50))
357 ELSE
358 OOC_FCT_TYPE_TMP = -5959
359 ENDIF
360 CALL DMUMPS_CHAIN_PRUN_NODES_STATS(
361 & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485),
362 & KEEP8(31)+KEEP8(64),
363 & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP
364 & )
365 IF (DO_NBSPARSE) THEN
366 nb_sparse = max(1,KEEP(497))
367 MODE_RHS_BOUNDS = 0
368 IF (Exploit_Sparsity) MODE_RHS_BOUNDS = 2
369 CALL DMUMPS_INITIALIZE_RHS_BOUNDS(
370 & STEP, N,
371 & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS,
372 & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243),
373 & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23),
374 & RHS_BOUNDS, KEEP(28),
375 & nb_sparse, MYID_NODES,
376 & MODE_RHS_BOUNDS)
377 CALL DMUMPS_PROPAGATE_RHS_BOUNDS(
378 & Pruned_Leaves, nb_prun_leaves,
379 & STEP, N, Pruned_SONS,
380 & DAD, RHS_BOUNDS, KEEP(28),
381 & MYID_NODES, COMM_NODES, KEEP(485),
382 & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0,
383 & KEEP(50), KEEP(38))
384 END IF
385 SPECIAL_ROOT_REACHED = .FALSE.
386 DO I= 1, nb_prun_roots
387.EQ..OR. IF ( (Pruned_Roots(I)KEEP(38))
388.EQ. & (Pruned_Roots(I)KEEP(20)) ) THEN
389 SPECIAL_ROOT_REACHED = .TRUE.
390 EXIT
391 ENDIF
392 ENDDO
393 DEALLOCATE(Pruned_List)
394 ENDIF
395.GT. IF (KEEP(201)0) THEN
396.OR. IF (DOFORWARD DOROOT_FWD_OOC) THEN
397 CALL DMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE,
398 & A,LA,DOFORWARD,IERR)
399.LT. IF(IERR0)THEN
400 INFO(1)=IERR
401 INFO(2)=0
402 CALL MUMPS_ABORT()
403 ENDIF
404 ENDIF
405 ENDIF
406 IF (DOFORWARD) THEN
407.eq. IF ( KEEP( 50 ) 0 ) THEN
408 MTYPE_LOC = MTYPE
409 ELSE
410 MTYPE_LOC = 1
411 ENDIF
412#if defined(V_T)
413 CALL VTBEGIN(forw_soln,ierr)
414#endif
415.NOT. IF ( DO_PRUN ) THEN
416 CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES,
417 & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS)
418 DO ISTEP =1, KEEP(28)
419 IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP)
420 ENDDO
421 ELSE
422 CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N,
423 & nb_prun_roots, Pruned_Roots,
424 & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP,
425 & PROCNODE_STEPS )
426 IF (AM1) THEN
427 DEALLOCATE(Pruned_Roots)
428 END IF
429.AND..EQ. IF ((Exploit_Sparsity)(nb_prun_rootsNA(2))) THEN
430 DEALLOCATE(Pruned_Roots)
431 SWITCH_OFF_ES = .TRUE.
432 ENDIF
433 DO ISTEP = 1, KEEP(28)
434 IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP)
435 ENDDO
436 ENDIF
437 IF ( DO_L0OMP_FWD ) THEN
438 CALL DMUMPS_SOL_L0OMP_R( N, MTYPE_LOC, NRHS, LIW, IW,
439 & IW1(PTRICB), RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD,
440 & STEP, FRERE, DAD, FILS, IW1(NSTK_S),
441 & PTRIST, PTRFAC, INFO,
442 & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF,
443 & COMM_NODES, MYID_NODES,
444 & BUFR, LBUFR, LBUFR_BYTES,
445 & RHS_ROOT, LRHS_ROOT,
446 & ISTEP_TO_INIV2, TAB_POS_IN_PERE,
447 & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE,
448 & FROM_PP,
449 & NBROOT_UNDER_L0,
450 & LPOOL_B_L0_OMP, IPOOL_B_L0_OMP,
451 & L_VIRT_L0_OMP, VIRT_L0_OMP,
452 & L_PHYS_L0_OMP, PHYS_L0_OMP,
453 & PERM_L0_OMP, PTR_LEAFS_L0_OMP,
454 & L0_OMP_MAPPING, LL0_OMP_MAPPING,
455 & L0_OMP_FACTORS, LL0_OMP_FACTORS,
456 & DO_PRUN, TO_PROCESS
457 & )
458 MYROOT = MYROOT - NBROOT_UNDER_L0
459 IF ( DO_PRUN ) THEN
460 MYLEAF_NOT_PRUNED = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP)
461 DO I=1, MYLEAF_NOT_PRUNED
462 IF ( TO_PROCESS( STEP( IPOOL_A_L0_OMP(I) ))) THEN
463 IW1(IPOOL+MYLEAF-1) = IPOOL_A_L0_OMP(I)
464 IW1(NSTK_S+STEP(IPOOL_A_L0_OMP(I))-1) = -99
465 ENDIF
466 ENDDO
467 DO I = 1, nb_prun_leaves
468 INODE = Pruned_Leaves(I)
469 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199))
470.EQ. & MYID_NODES ) THEN
471.EQ. IF (L0_OMP_MAPPING( STEP(INODE) ) 0) THEN
472 IW1(NSTK_S+STEP(INODE)-1) = -99
473 ENDIF
474 ENDIF
475 ENDDO
476 DO I = 1, L_PHYS_L0_OMP
477 INODE = DAD(STEP(PHYS_L0_OMP(I)))
478.NE. IF (INODE 0) THEN
479 IF ( TO_PROCESS( STEP( INODE ))) THEN
480.EQ. IF ( IW1(NSTK_S+STEP(INODE)-1) 0 ) THEN
481 IW1(NSTK_S+STEP(INODE)-1) = -99
482 ENDIF
483 ENDIF
484 ENDIF
485 ENDDO
486 MYLEAF = 0
487 DO ISTEP = KEEP(28), 1, -1
488 INODE=Step2Node(ISTEP)
489.EQ. IF (IW1(NSTK_S+STEP(INODE)-1)-99) THEN
490 MYLEAF = MYLEAF + 1
491 IW1(IPOOL+MYLEAF-1) = INODE
492 IW1(NSTK_S+STEP(INODE)-1) = 0
493 ENDIF
494 ENDDO
495 DEALLOCATE(Pruned_Leaves)
496 ELSE
497 MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP)
498 DO I=1, MYLEAF
499 IW1(IPOOL+I-1) = IPOOL_A_L0_OMP(I)
500 ENDDO
501 ENDIF
502 ELSE
503 IF ( DO_PRUN ) THEN
504 CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES,
505 & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8,
506 & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL )
507 MYLEAF = MYLEAF - 1
508 DEALLOCATE(Pruned_Leaves)
509 ELSE
510 CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES,
511 & SLAVEF, NA, LNA, KEEP, KEEP8, STEP,
512 & PROCNODE_STEPS, IW1(IPOOL), LPOOL )
513 MYLEAF = MYLEAF - 1
514 ENDIF
515 ENDIF
516 CALL DMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1),
517 & LWC, NRHS,
518 & IW1(PTRICB), IWCB, LIWW,
519 & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD,
520 & STEP, FRERE,DAD,FILS,
521 & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC,
522 & MYLEAF, MYROOT, INFO,
523 & KEEP, KEEP8, DKEEP,
524 & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES,
525 & BUFR, LBUFR, LBUFR_BYTES,
526 & RHS_ROOT, LRHS_ROOT, MTYPE_LOC,
527 &
528 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
529 & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP
530 & , L0_OMP_MAPPING, LL0_OMP_MAPPING,
531 & L0_OMP_FACTORS, LL0_OMP_FACTORS
532 & )
533 IF (DO_PRUN) THEN
534 MYLEAF = -1
535 ENDIF
536#if defined(V_T)
537 CALL VTEND(forw_soln,ierr)
538#endif
539 ENDIF
540 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
541.LT. IF ( INFO(1) 0 ) THEN
542.GT. IF ( LP 0 ) THEN
543 WRITE(LP,*) MYID,
544 & ': ** ERROR RETURN FROM DMUMPS_SOL_R,INFO(1:2)=',
545 & INFO(1:2)
546 END IF
547 GOTO 500
548 END IF
549 CALL MPI_BARRIER( COMM_NODES, IERR )
550.NOT. IF (FROM_PP) THEN
551 CALL MUMPS_SECFIN(TIME_FWD)
552 DKEEP(117)=TIME_FWD + DKEEP(117)
553 ENDIF
554.AND. IF (DO_PRUNSWITCH_OFF_ES) THEN
555 DO_PRUN = .FALSE.
556 Exploit_Sparsity = .FALSE.
557.NOT. IF ( DO_L0OMP_BWD ) THEN
558.AND..NE. IF ( allocated(TO_PROCESS) SIZE_TO_PROCESS1 ) THEN
559 DEALLOCATE (TO_PROCESS)
560 SIZE_TO_PROCESS = 1
561 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I)
562 ENDIF
563 ENDIF
564 ENDIF
565.AND. IF ( DOBACKWARD DO_PRUN ) THEN
566 nb_prun_leaves = 0
567.AND..EQ. IF ( Exploit_Sparsity (KEEP(111)0) ) THEN
568 nb_nodes_RHS = nb_prun_roots
569 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok)
570.GT. IF(allocok0) THEN
571 WRITE(*,*)'Problem with allocation of nodes_RHS'
572 INFO(1) = -13
573 INFO(2) = nb_nodes_RHS
574 CALL MUMPS_ABORT()
575 END IF
576 nodes_RHS(1:nb_prun_roots)=Pruned_Roots(1:nb_prun_roots)
577 DEALLOCATE(Pruned_Roots)
578 ELSE
579 nb_nodes_RHS = 0
580 Pruned_SONS(:) = -1
581 DO II = 1, NZ_RHS
582 I = IRHS_SPARSE(II)
583.NE. IF (KEEP(23)0) I = UNS_PERM_INV(I)
584 ISTEP = abs(STEP(I))
585.eq. IF ( Pruned_SONS(ISTEP) -1) THEN
586 nb_nodes_RHS = nb_nodes_RHS +1
587 Pruned_SONS(ISTEP) = 0
588 ENDIF
589 ENDDO
590 ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok)
591.GT. IF(allocok0) THEN
592 WRITE(*,*)'Problem with allocation of nodes_RHS'
593 INFO(1) = -13
594 INFO(2) = nb_nodes_RHS
595 CALL MUMPS_ABORT()
596 END IF
597 nb_nodes_RHS = 0
598 Pruned_SONS(:) = -1
599 DO II = 1, NZ_RHS
600 I = IRHS_SPARSE(II)
601.NE. IF (KEEP(23)0) I = UNS_PERM_INV(I)
602 ISTEP = abs(STEP(I))
603 INODE_PRINC = Step2node(ISTEP)
604.eq. IF ( Pruned_SONS(ISTEP) -1) THEN
605 nb_nodes_RHS = nb_nodes_RHS +1
606 nodes_RHS(nb_nodes_RHS) = INODE_PRINC
607 Pruned_SONS(ISTEP) = 0
608 ENDIF
609 ENDDO
610 ENDIF
611 IF ( Exploit_Sparsity ) THEN
612 CALL DMUMPS_TREE_PRUN_NODES(
613 & .FALSE.,
614 & DAD, NE_STEPS, FRERE, KEEP(28),
615 & FILS, STEP, N,
616 & nodes_RHS, nb_nodes_RHS,
617 & TO_PROCESS,
618 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves
619 & )
620 ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok)
621.GT. IF(allocok0) THEN
622 INFO(1)=-13
623 INFO(2)=nb_prun_nodes
624 END IF
625 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
626.LT. IF(INFO(1)0) GOTO 500
627 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok)
628.GT. IF(allocok0) THEN
629 INFO(1)=-13
630 INFO(2)=nb_prun_roots
631 END IF
632 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
633.LT. IF(INFO(1)0) GOTO 500
634 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok)
635.GT. IF(allocok0) THEN
636 INFO(1)=-13
637 INFO(2)=nb_prun_leaves
638 END IF
639 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
640.LT. IF(INFO(1)0) GOTO 500
641 CALL DMUMPS_TREE_PRUN_NODES(
642 & .TRUE.,
643 & DAD, NE_STEPS, FRERE, KEEP(28),
644 & FILS, STEP, N,
645 & nodes_RHS, nb_nodes_RHS,
646 & TO_PROCESS,
647 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves,
648 & Pruned_List, Pruned_Roots, Pruned_Leaves
649 & )
650 CALL DMUMPS_OOC_SET_STATES_ES(N,
651 & KEEP(201), Pruned_List, nb_prun_nodes,
652 & STEP)
653 IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS)
654.GT. IF (KEEP(201)0) THEN
655 OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE
656 & ('B',MTYPE,KEEP(201),KEEP(50))
657 ELSE
658 OOC_FCT_TYPE_TMP = -5959
659 ENDIF
660 CALL DMUMPS_TREE_PRUN_NODES_STATS(
661 & MYID_NODES, N, KEEP(28), KEEP(201),
662 & KEEP8(31)+KEEP8(64),
663 & STEP,
664 & Pruned_List,
665 & nb_prun_nodes, OOC_FCT_TYPE_TMP)
666 ENDIF
667 ENDIF
668.EQ..AND. IF(KEEP(201)1DOROOT_BWD_PANEL) THEN
669 I_WORKED_ON_ROOT = .FALSE.
670 CALL DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE,
671 & I_WORKED_ON_ROOT, IROOT, A, LA, IERR)
672.LT. IF (IERR 0) THEN
673 INFO(1) = -90
674 INFO(2) = IERR
675 ENDIF
676 ENDIF
677.EQ. IF (KEEP(201)1) THEN
678 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
679.LT. IF ( INFO(1) 0 ) GOTO 500
680 ENDIF
681.NE..AND..EQ. IF (KEEP(60)0 KEEP(221)0
682.AND..EQ. & MYID_NODES MASTER_ROOT) THEN
683 RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO
684 ENDIF
685.NOT. IF ( FROM_PP) THEN
686 CALL MUMPS_SECDEB(TIME_SpecialRoot)
687 ENDIF
688.NE..AND. IF ( ( KEEP( 38 ) 0 ) SPECIAL_ROOT_REACHED ) THEN
689.EQ..AND..EQ. IF ( KEEP(60) 0 KEEP(252) 0 ) THEN
690 IF ( root%yes ) THEN
691.GT. IF (KEEP(201)0) THEN
692.AND..NE..and. IF ( (Exploit_Sparsity(KEEP(111)0))
693.eq. & (OOC_STATE_NODE(STEP(KEEP(38)))-6) ) THEN
694 GOTO 1010
695 ENDIF
696 ENDIF
697 IOLDPS = PTRIST(STEP(KEEP(38)))
698 LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ))
699 LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ))
700.GT. IF (KEEP(201)0) THEN
701 CALL DMUMPS_SOLVE_GET_OOC_NODE(
702 & KEEP(38),PTRFAC,KEEP,A,LA,
703 & STEP,KEEP8,N,DUMMY_BOOL,IERR)
704.LT. IF(IERR0)THEN
705 INFO(1)=IERR
706 INFO(2)=0
707 WRITE(*,*) '** ERROR after DMUMPS_SOLVE_GET_OOC_NODE',
708 & INFO(1)
709 call MUMPS_ABORT()
710 ENDIF
711 ENDIF
712 IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ)))
713.EQ. IF (LOCAL_M * LOCAL_N 0) THEN
714 IAPOS = min(IAPOS, LA)
715 ENDIF
716#if defined(V_T)
717 CALL VTBEGIN(root_soln,ierr)
718#endif
719 CALL DMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1),
720 & root%CNTXT_BLACS, LOCAL_M, LOCAL_N,
721 & root%MBLOCK, root%NBLOCK,
722 & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES,
723 & COMM_NODES,
724 & RHS_ROOT(1),
725 & root%TOT_ROOT_SIZE, A( IAPOS ),
726 & INFO(1), MTYPE, KEEP(50), FROM_PP)
727.GT. IF(KEEP(201)0)THEN
728 CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38),
729 & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR)
730.LT. IF(IERR0)THEN
731 INFO(1)=IERR
732 INFO(2)=0
733 WRITE(*,*)
734 & '** ERROR after DMUMPS_FREE_FACTORS_FOR_SOLVE ',
735 & INFO(1)
736 call MUMPS_ABORT()
737 ENDIF
738 ENDIF
739 ENDIF
740 ENDIF
741.NE..AND. ELSE IF ( ( KEEP(20) 0) SPECIAL_ROOT_REACHED ) THEN
742.eq. IF ( MYID_NODES MASTER_ROOT ) THEN
743 END IF
744 END IF
745.NOT. IF (FROM_PP) THEN
746 CALL MUMPS_SECFIN(TIME_SpecialRoot)
747 DKEEP(119)=TIME_SpecialRoot + DKEEP(119)
748 ENDIF
749#if defined(V_T)
750 CALL VTEND(root_soln,ierr)
751#endif
752 1010 CONTINUE
753 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
754.LT. IF ( INFO(1) 0 ) RETURN
755 IF (DOBACKWARD) THEN
756.GT..AND..NOT. IF ( KEEP(201)0 DOROOT_BWD_PANEL )
757 & THEN
758 I_WORKED_ON_ROOT = DOROOT
759.gt. IF (KEEP(38)0 ) THEN
760.AND..EQ. IF ( ( Exploit_Sparsity(KEEP(111)0) )
761.OR. & AM1 ) THEN
762.eq. IF (OOC_STATE_NODE(STEP(KEEP(38)))-6) THEN
763 OOC_STATE_NODE(STEP(KEEP(38)))=-4
764 ENDIF
765 ENDIF
766.AND..NE. IF (Exploit_Sparsity(KEEP(111)0)) THEN
767.eq. IF (OOC_STATE_NODE(STEP(KEEP(38)))-6) THEN
768 I_WORKED_ON_ROOT = .FALSE.
769 ENDIF
770 ENDIF
771 ENDIF
772 ENDIF
773.NOT. IF (AM1) THEN
774 DO_NBSPARSE_BWD = .FALSE.
775 ELSE
776 DO_NBSPARSE_BWD = DO_NBSPARSE
777 ENDIF
778 PRUN_BELOW_BWD = AM1
779.OR. PRUN_BELOW_BWD = PRUN_BELOW_BWD DO_L0OMP_BWD
780 IF ( AM1 ) THEN
781 CALL DMUMPS_CHAIN_PRUN_NODES(
782 & .FALSE.,
783 & DAD, KEEP(28),
784 & STEP, N,
785 & nodes_RHS, nb_nodes_RHS,
786 & Pruned_SONS, TO_PROCESS,
787 & nb_prun_nodes, nb_prun_roots,
788 & nb_prun_leaves)
789 ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok)
790.GT. IF(allocok0) THEN
791 INFO(1)=-13
792 INFO(2)=nb_prun_nodes
793 END IF
794 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
795.LT. IF(INFO(1)0) GOTO 500
796 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok)
797.GT. IF(allocok0) THEN
798 INFO(1)=-13
799 INFO(2)=nb_prun_roots
800 END IF
801 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
802.LT. IF(INFO(1)0) GOTO 500
803 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok)
804.GT. IF(allocok0) THEN
805 INFO(1)=-13
806 INFO(2)=nb_prun_leaves
807 END IF
808 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
809.LT. IF(INFO(1)0) GOTO 500
810 CALL DMUMPS_CHAIN_PRUN_NODES(
811 & .TRUE.,
812 & DAD, KEEP(28),
813 & STEP, N,
814 & nodes_RHS, nb_nodes_RHS,
815 & Pruned_SONS, TO_PROCESS,
816 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves,
817 & Pruned_List, Pruned_Roots, Pruned_Leaves )
818 CALL DMUMPS_OOC_SET_STATES_ES(N,
819 & KEEP(201), Pruned_List, nb_prun_nodes,
820 & STEP)
821.GT. IF (KEEP(201)0) THEN
822 OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE
823 & ('B',MTYPE,KEEP(201),KEEP(50))
824 ELSE
825 OOC_FCT_TYPE_TMP = -5959
826 ENDIF
827 CALL DMUMPS_CHAIN_PRUN_NODES_STATS(
828 & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31),
829 & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP
830 & )
831 IF (DO_NBSPARSE_BWD) THEN
832 nb_sparse = max(1,KEEP(497))
833 CALL DMUMPS_INITIALIZE_RHS_BOUNDS(
834 & STEP, N,
835 & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS,
836 & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243),
837 & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23),
838 & RHS_BOUNDS, KEEP(28),
839 & nb_sparse, MYID_NODES,
840 & 1)
841 CALL DMUMPS_PROPAGATE_RHS_BOUNDS(
842 & Pruned_Leaves, nb_prun_leaves,
843 & STEP, N, Pruned_SONS,
844 & DAD, RHS_BOUNDS, KEEP(28),
845 & MYID_NODES, COMM_NODES, KEEP(485),
846 & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1,
847 & KEEP(50), KEEP(38))
848 END IF
849 ENDIF
850.GT. IF ( KEEP(201)0 ) THEN
851 IROOT = max(KEEP(20),KEEP(38))
852 CALL DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE,
853 & I_WORKED_ON_ROOT, IROOT, A, LA, IERR)
854 ENDIF
855.eq. IF ( KEEP( 50 ) 0 ) THEN
856 MTYPE_LOC = MTYPE
857 ELSE
858 MTYPE_LOC = 0
859 ENDIF
860#if defined(V_T)
861 CALL VTBEGIN(back_soln,ierr)
862#endif
863.NOT. IF (FROM_PP) THEN
864 CALL MUMPS_SECDEB(TIME_BWD)
865 ENDIF
866.NOT. IF ( SPECIAL_ROOT_REACHED ) THEN
867 RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO
868 ENDIF
869.AND..NE. IF (AM1(NB_FS_IN_RHSCOMP_FNB_FS_IN_RHSCOMP_TOT)) THEN
870 DO I =1, N
871 II = POSINRHSCOMP_BWD(I)
872.GT..AND..GT. IF ((II0)(IINB_FS_IN_RHSCOMP_F)) THEN
873 DO K=1,NRHS
874 RHSCOMP(II, K) = ZERO
875 ENDDO
876 ENDIF
877 ENDDO
878 ENDIF
879.NOT. IF ( DO_PRUN ) THEN
880.NOT. IF ( DO_L0OMP_BWD ) THEN
881 IF (DO_L0OMP_FWD) THEN
882 MYLEAF = -1
883 ENDIF
884 ENDIF
885 IF ( DO_L0OMP_BWD ) THEN
886 TO_PROCESS(:) = .TRUE.
887 DO I=1, L_PHYS_L0_OMP
888 TO_PROCESS( STEP(PHYS_L0_OMP( I )))
889 & = .FALSE.
890 ENDDO
891.EQ. IF (MYLEAF -1) THEN
892 MYLEAF = IPOOL_A_L0_OMP(LPOOL_A_L0_OMP)
893 ENDIF
894 CALL MUMPS_INIT_POOL_DIST_NA_BWD_L0( N, MYROOT, MYID_NODES,
895 & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
896 & IW1(IPOOL), LPOOL, L0_OMP_MAPPING )
897 ELSE
898 CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES,
899 & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
900 & IW1(IPOOL), LPOOL )
901.EQ. IF (MYLEAF -1) THEN
902 CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N,
903 & NA(1),
904 & NA(3),
905 & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP,
906 & PROCNODE_STEPS )
907 ENDIF
908 ENDIF
909 ELSE
910 IF ( DO_L0OMP_BWD ) THEN
911 DO I=1, L_PHYS_L0_OMP
912 IF ( TO_PROCESS( STEP(PHYS_L0_OMP( I ))) ) THEN
913 TO_PROCESS( STEP(PHYS_L0_OMP( I ))) = .FALSE.
914 PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I )
915 ENDIF
916 ENDDO
917 MYLEAF=0
918 DO ISTEP = 1, KEEP(28)
919 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))
920.NE. & MYID_NODES ) THEN
921 CYCLE
922 ENDIF
923.NE. IF ( L0_OMP_MAPPING( ISTEP ) 0 ) THEN
924 CYCLE
925 ENDIF
926.NOT. IF ( TO_PROCESS( ISTEP ) ) THEN
927 CYCLE
928 ENDIF
929 I = Step2Node( ISTEP )
930 ICHILD = FILS ( I )
931.GT. DO WHILE ( ICHILD 0 )
932 ICHILD = FILS( ICHILD )
933 END DO
934.LT. IF ( ICHILD 0 ) THEN
935 ICHILD = -ICHILD
936.GT. DO WHILE ( ICHILD 0 )
937.EQ..AND. IF ( L0_OMP_MAPPING( STEP( ICHILD ) ) 0
938 & TO_PROCESS(STEP( ICHILD )) ) THEN
939 GOTO 10
940 ENDIF
941 ICHILD = FRERE( STEP( ICHILD ) )
942 ENDDO
943 ENDIF
944 MYLEAF = MYLEAF + 1
945 10 CONTINUE
946 ENDDO
947 CALL MUMPS_INIT_POOL_DIST_NA_BWDL0ES( N, MYROOT,
948 & MYID_NODES,
949 & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
950 & IW1(IPOOL), LPOOL, L0_OMP_MAPPING, TO_PROCESS )
951 ELSE
952 CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots,
953 & Pruned_Roots,
954 & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS,
955 & IW1(IPOOL), LPOOL)
956 CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N,
957 & nb_prun_leaves, Pruned_Leaves,
958 & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP,
959 & PROCNODE_STEPS )
960 ENDIF
961 ENDIF
962 IF ( DO_L0OMP_BWD
963 & ) THEN
964 KEEP(31) = 1
965 ELSE
966 KEEP(31) = 0
967 ENDIF
968.EQ. IF (KEEP(31) 1) THEN
969 DO I = 1, KEEP(28)
970.EQ. IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199))
971 & MYID_NODES) THEN
972.NOT. IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I),
973 & KEEP(199)) ) THEN
974.EQ. IF ( L0_OMP_MAPPING(I) 0 ) THEN
975 IF ( DO_PRUN
976.OR. & DO_L0OMP_BWD
977 & ) THEN
978 IF ( TO_PROCESS(I) ) THEN
979 KEEP(31) = KEEP(31) + 1
980 ENDIF
981 ELSE
982 KEEP(31) = KEEP(31) + 1
983 ENDIF
984 ENDIF
985 ENDIF
986 ENDIF
987 ENDDO
988 ENDIF
989 CALL DMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC,
990 & NRHS,
991 & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD,
992 & IW1(PTRICB),PTRACB,IWCB,LIWW, W2,
993 & NE_STEPS,
994 & STEP, FRERE,DAD,FILS,
995 & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO,
996 & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES,
997 & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP,
998 & RHS_ROOT, LRHS_ROOT,
999 & MTYPE_LOC,
1000 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS),
1001 & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS
1002 & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD
1003 & , FROM_PP
1004 & , L0_OMP_MAPPING, LL0_OMP_MAPPING,
1005 & L0_OMP_FACTORS, LL0_OMP_FACTORS
1006 & )
1007.AND. IF ( DO_L0OMP_BWD DO_PRUN ) THEN
1008 DO I = 1, L_PHYS_L0_OMP
1009.LT. IF ( PHYS_L0_OMP( I ) 0 ) THEN
1010 PHYS_L0_OMP( I ) = -PHYS_L0_OMP( I )
1011 TO_PROCESS(STEP(PHYS_L0_OMP( I ) )) = .TRUE.
1012 ENDIF
1013 ENDDO
1014 ENDIF
1015.AND..GE. IF (DO_L0OMP_BWD INFO(1) 0) THEN
1016 KEEP(31) = 0
1017 PRUN_BELOW_BWD = AM1
1018 CALL DMUMPS_SOL_L0OMP_S(N, MTYPE_LOC, NRHS, LIW, IW,
1019 & IW1(PTRICB), PTRACB, RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD,
1020 & STEP, FRERE, FILS, NE_STEPS, PTRIST, PTRFAC, INFO,
1021 & KEEP, KEEP8, DKEEP, PROCNODE_STEPS, SLAVEF,
1022 & COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES,
1023 & RHS_ROOT, LRHS_ROOT, ISTEP_TO_INIV2, TAB_POS_IN_PERE,
1024 & IW1(IPANEL_POS), LPANEL_POS,
1025 & PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS,
1026 & RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD,
1027 & FROM_PP,
1028 & LPOOL_B_L0_OMP,
1029 & L_VIRT_L0_OMP, VIRT_L0_OMP,
1030 & L_PHYS_L0_OMP, PHYS_L0_OMP,
1031 & PERM_L0_OMP, PTR_LEAFS_L0_OMP,
1032 & L0_OMP_MAPPING, LL0_OMP_MAPPING,
1033 & L0_OMP_FACTORS, LL0_OMP_FACTORS )
1034 ENDIF
1035 CALL DMUMPS_CLEAN_PENDING( INFO(1), KEEP,
1036 & BUFR, LBUFR,LBUFR_BYTES,
1037 & COMM_NODES, IDUMMY,
1038 & SLAVEF, .TRUE., .FALSE. )
1039 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID )
1040#if defined(V_T)
1041 CALL VTEND(back_soln,ierr)
1042#endif
1043.NOT. IF (FROM_PP) THEN
1044 CALL MUMPS_SECFIN(TIME_BWD)
1045 DKEEP(118)=TIME_BWD+DKEEP(118)
1046 ENDIF
1047 ENDIF
1048.GT..AND..GT. IF (LDIAG2 MP0) THEN
1049 IF (DOFORWARD) THEN
1050 K = min0(10,size(RHSCOMP,1))
1051.EQ. IF (LDIAG4) K = size(RHSCOMP,1)
1052.NOT. IF ( FROM_PP) THEN
1053 WRITE (MP,99992)
1054.GT. IF (size(RHSCOMP,1)0)
1055 & WRITE (MP,99993) (RHSCOMP(I,1),I=1,K)
1056.GT..and. IF (size(RHSCOMP,1)0NRHS>1)
1057 & WRITE (MP,99994) (RHSCOMP(I,2),I=1,K)
1058 ENDIF
1059 ENDIF
1060 ENDIF
1061500 CONTINUE
1062 IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS)
1063.OR..OR. IF (Exploit_SparsityAM1SWITCH_OFF_ES) THEN
1064 IF ( allocated(nodes_RHS)) DEALLOCATE (nodes_RHS)
1065 IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS)
1066 IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots)
1067 IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List)
1068 IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves)
1069 ENDIF
1070 RETURN
107199993 FORMAT (' RHS (internal, first column)'/(1X,1P,5D14.6))
107299994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5D14.6))
107399992 FORMAT (//' LEAVING SOLVE (DMUMPS_SOL_C) WITH')
1074 END SUBROUTINE DMUMPS_SOL_C
1075 SUBROUTINE DMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM,
1076 & NRHS,
1077 & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST,
1078 & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER,
1079 & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK,
1080 & LSCAL, SCALING, LSCALING,
1081 & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP,
1082 & POSINRHSCOMP, LPOS_N, PERM_RHS, SIZE_PERM_RHS )
1083!$ USE OMP_LIB
1084 IMPLICIT NONE
1085 INCLUDE 'mpif.h'
1086 INCLUDE 'mumps_tags.h'
1087 INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS
1088 INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSCOMP
1089 DOUBLE PRECISION RHS (LRHS, NCOL_RHS)
1090 INTEGER, INTENT(in) :: JBEG_RHS
1091 INTEGER KEEP(500)
1092 INTEGER(8) KEEP8(150)
1093 DOUBLE PRECISION :: CWORK(LCWORK)
1094 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
1095 INTEGER IW(LIW), STEP(N)
1096 INTEGER SIZE_BUF, SIZE_BUF_BYTES
1097 INTEGER BUFFER(SIZE_BUF)
1098 INTEGER LRHSCOMP, POSINRHSCOMP(LPOS_N)
1099 DOUBLE PRECISION, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP)
1100 LOGICAL, intent(in) :: LSCAL
1101 INTEGER, intent(in) :: LSCALING
1102 DOUBLE PRECISION, intent(in) :: SCALING(LSCALING)
1103 INTEGER, INTENT(in) :: SIZE_PERM_RHS
1104 INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS)
1105 INTEGER I, II, J, J1, ISTEP, MASTER,
1106 & MYID_NODES, TYPE_PARAL, N2RECV
1107 INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf
1108 INTEGER :: STATUS(MPI_STATUS_SIZE)
1109 INTEGER :: IERR, allocok
1110 PARAMETER(MASTER=0)
1111 LOGICAL I_AM_SLAVE
1112 INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2
1113 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP
1114 INTEGER :: JCOL_RHS
1115 INTEGER :: K242
1116 LOGICAL :: OMP_FLAG
1117!$ INTEGER :: CHUNK, NOMP
1118 INTEGER, PARAMETER :: FIN = -1
1119 DOUBLE PRECISION ZERO
1120 PARAMETER( ZERO = 0.0D0 )
1121 INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist
1122 INCLUDE 'mumps_headers.h'
1123 INTEGER, EXTERNAL :: MUMPS_PROCNODE
1124 TYPE_PARAL = KEEP(46)
1125.ne..OR..eq. I_AM_SLAVE = MYID MASTER TYPE_PARAL 1
1126 IF ( TYPE_PARAL == 1 ) THEN
1127 MYID_NODES = MYID
1128 ELSE
1129 MYID_NODES = MYID-1
1130 ENDIF
1131.EQ..AND..EQ. IF (NSLAVES1 TYPE_PARAL1) THEN
1132 IF (LSCAL) THEN
1133 OMP_FLAG = .FALSE.
1134.EQ. IF (KEEP(350)2) THEN
1135 K242 = KEEP(242)
1136!$ NOMP = OMP_GET_MAX_THREADS()
1137!$ CHUNK = max(N/2,1)
1138.GE.!$ IF (int(NRHS,8) * int(N,8) int(KEEP(363),8)) THEN
1139!$ OMP_FLAG = .TRUE.
1140!$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8))
1141!$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362))
1142!$ CHUNK = max(KEEP(363)/2,CHUNK)
1143!$ ENDIF
1144 ENDIF
1145 IF (OMP_FLAG) THEN
1146!$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242)
1147!$OMP& PRIVATE(J,IPOSINRHSCOMP,I,JCOL_RHS)
1148 DO J=1, NRHS
1149.EQ. IF (K2420) THEN
1150 JCOL_RHS = J+JBEG_RHS-1
1151 ELSE
1152 JCOL_RHS = PERM_RHS(J+JBEG_RHS-1)
1153 ENDIF
1154!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
1155 DO I=1, N
1156 IPOSINRHSCOMP = POSINRHSCOMP(I)
1157.GT. IF (IPOSINRHSCOMP0) THEN
1158 RHS(I,JCOL_RHS) =
1159 & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I)
1160 ELSE
1161 RHS(I,JCOL_RHS) = ZERO
1162 ENDIF
1163 ENDDO
1164!$OMP END DO NOWAIT
1165 ENDDO
1166!$OMP END PARALLEL
1167 ELSE
1168 DO J=1, NRHS
1169.EQ. IF (KEEP(242)0) THEN
1170 JCOL_RHS = J+JBEG_RHS-1
1171 ELSE
1172 JCOL_RHS = PERM_RHS(J+JBEG_RHS-1)
1173 ENDIF
1174 DO I=1, N
1175 IPOSINRHSCOMP = POSINRHSCOMP(I)
1176.GT. IF (IPOSINRHSCOMP0) THEN
1177 RHS(I,JCOL_RHS) =
1178 & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I)
1179 ELSE
1180 RHS(I,JCOL_RHS) = ZERO
1181 ENDIF
1182 ENDDO
1183 ENDDO
1184 ENDIF
1185 ELSE
1186 OMP_FLAG = .FALSE.
1187.EQ. IF (KEEP(350)2) THEN
1188 K242 = KEEP(242)
1189!$ NOMP = OMP_GET_MAX_THREADS()
1190!$ OMP_FLAG = .FALSE.
1191!$ CHUNK = max(N/2,1)
1192.GE.!$ IF (NRHS * N KEEP(363)) THEN
1193!$ OMP_FLAG = .TRUE.
1194!$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8))
1195!$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362))
1196!$ CHUNK = max(KEEP(363)/2,CHUNK)
1197!$ ENDIF
1198 ENDIF
1199 IF (OMP_FLAG) THEN
1200!$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242)
1201!$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG)
1202 DO J=1, NRHS
1203.EQ. IF (K2420) THEN
1204 JCOL_RHS = J+JBEG_RHS-1
1205 ELSE
1206 JCOL_RHS = PERM_RHS(J+JBEG_RHS-1)
1207 ENDIF
1208!$OMP DO SCHEDULE(DYNAMIC,CHUNK)
1209 DO I=1, N
1210 IPOSINRHSCOMP = POSINRHSCOMP(I)
1211.GT. IF (IPOSINRHSCOMP0) THEN
1212 RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J)
1213 ELSE
1214 RHS(I,JCOL_RHS) = ZERO
1215 ENDIF
1216 ENDDO
1217!$OMP END DO NOWAIT
1218 ENDDO
1219!$OMP END PARALLEL
1220 ELSE
1221 DO J=1, NRHS
1222.EQ. IF (KEEP(242)0) THEN
1223 JCOL_RHS = J+JBEG_RHS-1
1224 ELSE
1225 JCOL_RHS = PERM_RHS(J+JBEG_RHS-1)
1226 ENDIF
1227 DO I=1, N
1228 IPOSINRHSCOMP = POSINRHSCOMP(I)
1229.GT. IF (IPOSINRHSCOMP0) THEN
1230 RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J)
1231 ELSE
1232 RHS(I,JCOL_RHS) = ZERO
1233 ENDIF
1234 ENDDO
1235 ENDDO
1236 ENDIF
1237 ENDIF
1238 RETURN
1239 ENDIF
1240 MAXNPIV_estim = max(KEEP(246), KEEP(247))
1241 MAXSurf = MAXNPIV_estim*NRHS
1242.LT. IF (LCWORK MAXNPIV_estim) THEN
1243 WRITE(*,*) MYID,
1244 & ": internal error 2 in dmumps_gather_solution:",
1245 & TYPE_PARAL, LCWORK, KEEP(247), NRHS
1246 CALL MUMPS_ABORT()
1247 ENDIF
1248.EQ. IF (MYIDMASTER) THEN
1249 ALLOCATE(IROWlist(KEEP(247)),stat=allocok)
1250.GT. IF(allocok0) THEN
1251 WRITE(*,*)'Problem with allocation of IROWlist'
1252 CALL MUMPS_ABORT()
1253 ENDIF
1254 ENDIF
1255.EQ..AND..EQ. IF (NSLAVES 1 TYPE_PARAL 1) THEN
1256 CALL MUMPS_ABORT()
1257 ENDIF
1258 SIZE1=0
1259 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM,
1260 & SIZE1, IERR)
1261 SIZE2=0
1262 CALL MPI_PACK_SIZE(MAXSurf,MPI_DOUBLE_PRECISION, COMM,
1263 & SIZE2, IERR)
1264 RECORD_SIZE_P_1= SIZE1+SIZE2
1265.GT. IF (RECORD_SIZE_P_1SIZE_BUF_BYTES) THEN
1266 write(6,*) MYID,
1267 & ' Internal error 3 in DMUMPS_GATHER_SOLUTION '
1268 write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=',
1269 & RECORD_SIZE_P_1, SIZE_BUF_BYTES
1270 CALL MUMPS_ABORT()
1271 ENDIF
1272 N2SEND =0
1273 N2RECV =N
1274 POS_BUF =0
1275 IF (I_AM_SLAVE) THEN
1276 POS_BUF = 0
1277 DO ISTEP = 1, KEEP(28)
1278 IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),
1279 & KEEP(199))) THEN
1280 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
1281 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N)
1282.eq..AND..EQ. IF (MTYPE1 KEEP(50)0) THEN
1283 J1=IPOS+1+LIELL
1284 ELSE
1285 J1=IPOS+1
1286 END IF
1287.EQ. IF (MYID MASTER) THEN
1288 N2RECV=N2RECV-NPIV
1289.GT. IF (NPIV0)
1290 & CALL DMUMPS_NPIV_BLOCK_ADD ( .TRUE. )
1291 ELSE
1292.GT. IF (NPIV0)
1293 & CALL DMUMPS_NPIV_BLOCK_ADD ( .FALSE.)
1294 ENDIF
1295 ENDIF
1296 ENDDO
1297 CALL DMUMPS_NPIV_BLOCK_SEND()
1298 ENDIF
1299.EQ. IF ( MYID MASTER ) THEN
1300.NE. DO WHILE (N2RECV 0)
1301 CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED,
1302 & MPI_ANY_SOURCE,
1303 & GatherSol, COMM, STATUS, IERR )
1304 POS_BUF = 0
1305 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF,
1306 & NPIV, 1, MPI_INTEGER, COMM, IERR)
1307.NE. DO WHILE (NPIVFIN)
1308 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF,
1309 & IROWlist, NPIV, MPI_INTEGER, COMM, IERR)
1310 DO J=1, NRHS
1311.EQ. IF (KEEP(242)0) THEN
1312 JCOL_RHS=J+JBEG_RHS-1
1313 ELSE
1314 JCOL_RHS=PERM_RHS(J+JBEG_RHS-1)
1315 ENDIF
1316 CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF,
1317 & CWORK, NPIV, MPI_DOUBLE_PRECISION,
1318 & COMM, IERR)
1319 IF (LSCAL) THEN
1320 DO I=1,NPIV
1321 RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I))
1322 ENDDO
1323 ELSE
1324 DO I=1,NPIV
1325 RHS(IROWlist(I),JCOL_RHS)=CWORK(I)
1326 ENDDO
1327 ENDIF
1328 ENDDO
1329 N2RECV=N2RECV-NPIV
1330 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF,
1331 & NPIV, 1, MPI_INTEGER, COMM, IERR)
1332 ENDDO
1333 ENDDO
1334 DEALLOCATE(IROWlist)
1335 ENDIF
1336 RETURN
1337 CONTAINS
1338 SUBROUTINE DMUMPS_NPIV_BLOCK_ADD ( ON_MASTER )
1339 LOGICAL, intent(in) :: ON_MASTER
1340 INTEGER :: JPOS, K242
1341 LOGICAL :: LOCAL_LSCAL
1342 IF (ON_MASTER) THEN
1343.EQ. IF (KEEP(350)2
1344.AND..EQ..OR..GE. & (NRHS1((NPIV*NRHS*2*KEEP(16))KEEP(364)))) THEN
1345 LOCAL_LSCAL = LSCAL
1346 K242 = KEEP(242)
1347 DO J=1, NRHS
1348.EQ. IF (K2420) THEN
1349 JPOS = J+JBEG_RHS-1
1350 ELSE
1351 JPOS = PERM_RHS(J+JBEG_RHS-1)
1352 ENDIF
1353 DO II=1,NPIV
1354 I=IW(J1+II-1)
1355 IPOSINRHSCOMP= POSINRHSCOMP(I)
1356 IF (LOCAL_LSCAL) THEN
1357 RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I)
1358 ELSE
1359 RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J)
1360 ENDIF
1361 ENDDO
1362 ENDDO
1363 ELSE
1364.EQ. IF (KEEP(242)0) THEN
1365 IF (LSCAL) THEN
1366 DO II=1,NPIV
1367 I=IW(J1+II-1)
1368 IPOSINRHSCOMP= POSINRHSCOMP(I)
1369 DO J=1, NRHS
1370 RHS(I,J+JBEG_RHS-1) =
1371 & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I)
1372 ENDDO
1373 ENDDO
1374 ELSE
1375 DO II=1,NPIV
1376 I=IW(J1+II-1)
1377 IPOSINRHSCOMP= POSINRHSCOMP(I)
1378 DO J=1, NRHS
1379 RHS(I,J+JBEG_RHS-1) = RHSCOMP(IPOSINRHSCOMP,J)
1380 ENDDO
1381 ENDDO
1382 ENDIF
1383 ELSE
1384 IF (LSCAL) THEN
1385 DO II=1,NPIV
1386 I=IW(J1+II-1)
1387 IPOSINRHSCOMP= POSINRHSCOMP(I)
1388!DIR$ NOVECTOR
1389 DO J=1, NRHS
1390 RHS(I,PERM_RHS(J+JBEG_RHS-1)) =
1391 & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I)
1392 ENDDO
1393 ENDDO
1394 ELSE
1395 DO II=1,NPIV
1396 I=IW(J1+II-1)
1397 IPOSINRHSCOMP= POSINRHSCOMP(I)
1398!DIR$ NOVECTOR
1399 DO J=1, NRHS
1400 RHS(I,PERM_RHS(J+JBEG_RHS-1)) =
1401 & RHSCOMP(IPOSINRHSCOMP,J)
1402 ENDDO
1403 ENDDO
1404 ENDIF
1405 ENDIF
1406 ENDIF
1407 RETURN
1408 ENDIF
1409 CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER,
1410 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR )
1411 CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER,
1412 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR )
1413 IPOSINRHSCOMP= POSINRHSCOMP(IW(J1))
1414 DO J=1,NRHS
1415 CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV,
1416 & MPI_DOUBLE_PRECISION,
1417 & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM,
1418 & IERR)
1419 ENDDO
1420 N2SEND=N2SEND+NPIV
1421 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN
1422 CALL DMUMPS_NPIV_BLOCK_SEND()
1423 END IF
1424 RETURN
1425 END SUBROUTINE DMUMPS_NPIV_BLOCK_ADD
1426 SUBROUTINE DMUMPS_NPIV_BLOCK_SEND()
1427.NE. IF (N2SEND 0) THEN
1428 CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER,
1429 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR )
1430 CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER,
1431 & GatherSol, COMM, IERR)
1432 ENDIF
1433 POS_BUF=0
1434 N2SEND=0
1435 RETURN
1436 END SUBROUTINE DMUMPS_NPIV_BLOCK_SEND
1437 END SUBROUTINE DMUMPS_GATHER_SOLUTION
1438 SUBROUTINE DMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM,
1439 & NRHS, RHSCOMP, LRHSCOMP, NRHSCOMP_COL,
1440 & KEEP, BUFFER,
1441 & SIZE_BUF, SIZE_BUF_BYTES,
1442 & LSCAL, SCALING, LSCALING,
1443 & IRHS_PTR_COPY, LIRHS_PTR_COPY,
1444 & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY,
1445 & RHS_SPARSE_COPY, LRHS_SPARSE_COPY,
1446 & UNS_PERM_INV, LUNS_PERM_INV,
1447 & POSINRHSCOMP, LPOS_ROW, NB_FS_IN_RHSCOMP )
1448 IMPLICIT NONE
1449 INCLUDE 'mpif.h'
1450 INCLUDE 'mumps_tags.h'
1451 INTEGER NSLAVES, N, MYID, COMM
1452 INTEGER NRHS, LRHSCOMP, NRHSCOMP_COL
1453 DOUBLE PRECISION, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL)
1454 INTEGER KEEP(500)
1455 INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW
1456 INTEGER BUFFER(SIZE_BUF)
1457 INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY,
1458 & LRHS_SPARSE_COPY, LUNS_PERM_INV,
1459 & NB_FS_IN_RHSCOMP
1460 INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY),
1461 & IRHS_PTR_COPY(LIRHS_PTR_COPY),
1462 & UNS_PERM_INV(LUNS_PERM_INV),
1463 & POSINRHSCOMP(LPOS_ROW)
1464 DOUBLE PRECISION :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY)
1465 LOGICAL, intent(in) :: LSCAL
1466 INTEGER, intent(in) :: LSCALING
1467 DOUBLE PRECISION, intent(in) :: SCALING(LSCALING)
1468 INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC
1469 INTEGER I, II, J, MASTER,
1470 & TYPE_PARAL, N2RECV, IPOSINRHSCOMP
1471 INTEGER :: STATUS(MPI_STATUS_SIZE)
1472 INTEGER :: IERR
1473 PARAMETER(MASTER=0)
1474 LOGICAL I_AM_SLAVE
1475 INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2
1476 INTEGER POS_BUF, N2SEND
1477 INTEGER, PARAMETER :: FIN = -1
1478 INCLUDE 'mumps_headers.h'
1479 TYPE_PARAL = KEEP(46)
1480.ne..OR..eq. I_AM_SLAVE = MYID MASTER TYPE_PARAL 1
1481 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1
1482.EQ..AND..EQ. IF (NSLAVES1 TYPE_PARAL1) THEN
1483 K=1
1484 DO J = 1, NBCOL_INBLOC
1485 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J)
1486.EQ. IF (COLSIZE0) CYCLE
1487 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1
1488 I = IRHS_SPARSE_COPY(IZ)
1489.NE. IF (KEEP(23)0) I = UNS_PERM_INV(I)
1490 IPOSINRHSCOMP = POSINRHSCOMP(I)
1491.GT. IF (IPOSINRHSCOMP0) THEN
1492 IF (LSCAL) THEN
1493 RHS_SPARSE_COPY(IZ)=
1494 & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I)
1495 ELSE
1496 RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K)
1497 ENDIF
1498 ENDIF
1499 ENDDO
1500 K = K + 1
1501 ENDDO
1502 RETURN
1503 ENDIF
1504 IF (I_AM_SLAVE) THEN
1505 K=1
1506 DO J = 1, NBCOL_INBLOC
1507 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J)
1508.EQ. IF (COLSIZE0) CYCLE
1509 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1
1510 I = IRHS_SPARSE_COPY(IZ)
1511.NE. IF (KEEP(23)0) I = UNS_PERM_INV(I)
1512 IPOSINRHSCOMP = POSINRHSCOMP(I)
1513.GT. IF (IPOSINRHSCOMP0) THEN
1514 RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K)
1515 ENDIF
1516 ENDDO
1517 K = K + 1
1518 ENDDO
1519 ENDIF
1520 SIZE1=0
1521 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM,
1522 & SIZE1, IERR)
1523 SIZE2=0
1524 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_PRECISION, COMM,
1525 & SIZE2, IERR)
1526 RECORD_SIZE_P_1= SIZE1+SIZE2
1527.GT. IF (RECORD_SIZE_P_1SIZE_BUF_BYTES) THEN
1528 write(6,*) MYID,
1529 & ' Internal error 3 in DMUMPS_GATHER_SOLUTION_AM1 '
1530 write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=',
1531 & RECORD_SIZE_P_1, SIZE_BUF_BYTES
1532 CALL MUMPS_ABORT()
1533 ENDIF
1534 N2SEND =0
1535 N2RECV =size(IRHS_SPARSE_COPY)
1536 POS_BUF =0
1537 IF (I_AM_SLAVE) THEN
1538 DO J = 1, NBCOL_INBLOC
1539 COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J)
1540.LE. IF (COLSIZE0) CYCLE
1541 K = 0
1542 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1
1543 I = IRHS_SPARSE_COPY(IZ)
1544 II = I
1545.NE. IF (KEEP(23)0) II = UNS_PERM_INV(I)
1546 IPOSINRHSCOMP = POSINRHSCOMP(II)
1547.GT. IF (IPOSINRHSCOMP0) THEN
1548.EQ. IF (MYID MASTER) THEN
1549 N2RECV=N2RECV-1
1550 IF (LSCAL)
1551 & CALL DMUMPS_AM1_BLOCK_ADD ( .TRUE. )
1552 IRHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) =
1553 & I
1554 RHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) =
1555 & RHS_SPARSE_COPY(IZ)
1556 K = K+1
1557 ELSE
1558 CALL DMUMPS_AM1_BLOCK_ADD ( .FALSE. )
1559 ENDIF
1560 ENDIF
1561 ENDDO
1562.EQ. IF (MYIDMASTER)
1563 & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K
1564 ENDDO
1565 CALL DMUMPS_AM1_BLOCK_SEND()
1566 ENDIF
1567.EQ. IF ( MYID MASTER ) THEN
1568.NE. DO WHILE (N2RECV 0)
1569 CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED,
1570 & MPI_ANY_SOURCE,
1571 & GatherSol, COMM, STATUS, IERR )
1572 POS_BUF = 0
1573 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF,
1574 & J, 1, MPI_INTEGER, COMM, IERR)
1575.NE. DO WHILE (JFIN)
1576 IZ = IRHS_PTR_COPY(J)
1577 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF,
1578 & I, 1, MPI_INTEGER, COMM, IERR)
1579 IRHS_SPARSE_COPY(IZ) = I
1580 CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF,
1581 & RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_PRECISION,
1582 & COMM, IERR)
1583 IF (LSCAL) THEN
1584.NE. IF (KEEP(23)0) I = UNS_PERM_INV(I)
1585 RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I)
1586 ENDIF
1587 N2RECV=N2RECV-1
1588 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1
1589 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF,
1590 & J, 1, MPI_INTEGER, COMM, IERR)
1591 ENDDO
1592 ENDDO
1593 IPREV = 1
1594 DO J=1, size(IRHS_PTR_COPY)-1
1595 I= IRHS_PTR_COPY(J)
1596 IRHS_PTR_COPY(J) = IPREV
1597 IPREV = I
1598 ENDDO
1599 ENDIF
1600 RETURN
1601 CONTAINS
1602 SUBROUTINE DMUMPS_AM1_BLOCK_ADD ( SCALE_ONLY )
1603 LOGICAL, intent(in) :: SCALE_ONLY
1604 INTEGER III
1605 IF (SCALE_ONLY) THEN
1606 III = I
1607.NE. IF (KEEP(23)0) III = UNS_PERM_INV(I)
1608 IF (LSCAL) THEN
1609 RHS_SPARSE_COPY(IZ)=RHS_SPARSE_COPY(IZ)*SCALING(III)
1610 ENDIF
1611 RETURN
1612 ENDIF
1613 CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER,
1614 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR )
1615 CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER,
1616 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR )
1617 CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_PRECISION,
1618 & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM,
1619 & IERR)
1620 N2SEND=N2SEND+1
1621 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN
1622 CALL DMUMPS_AM1_BLOCK_SEND()
1623 END IF
1624 RETURN
1625 END SUBROUTINE DMUMPS_AM1_BLOCK_ADD
1626 SUBROUTINE DMUMPS_AM1_BLOCK_SEND()
1627.NE. IF (N2SEND 0) THEN
1628 CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER,
1629 & SIZE_BUF_BYTES, POS_BUF, COMM, IERR )
1630 CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER,
1631 & GatherSol, COMM, IERR)
1632 ENDIF
1633 POS_BUF=0
1634 N2SEND=0
1635 RETURN
1636 END SUBROUTINE DMUMPS_AM1_BLOCK_SEND
1637 END SUBROUTINE DMUMPS_GATHER_SOLUTION_AM1
1638 SUBROUTINE DMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC,
1639 & PTRIST, KEEP,KEEP8,
1640 & IW, LIW_PASSED, MYID_NODES, N, STEP,
1641 & PROCNODE, NSLAVES, scaling_data, LSCAL
1642 & , IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS
1643 & )
1644 IMPLICIT NONE
1645 INTEGER MTYPE, MYID_NODES, N, NSLAVES
1646 INTEGER KEEP(500)
1647 INTEGER(8) KEEP8(150)
1648 INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28))
1649 INTEGER ISOL_LOC(KEEP(89))
1650 INTEGER LIW_PASSED
1651 INTEGER IW(LIW_PASSED)
1652 INTEGER STEP(N)
1653 LOGICAL LSCAL
1654 LOGICAL :: IRHS_loc_MEANINGFUL
1655 INTEGER :: Nloc_RHS
1656 INTEGER :: IRHS_loc(Nloc_RHS)
1657 type scaling_data_t
1658 SEQUENCE
1659 DOUBLE PRECISION, dimension(:), pointer :: SCALING
1660 DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC
1661 end type scaling_data_t
1662 type (scaling_data_t) :: scaling_data
1663 INTEGER MUMPS_PROCNODE
1664 EXTERNAL MUMPS_PROCNODE
1665 INTEGER ISTEP, K
1666 INTEGER J1, IPOS, LIELL, NPIV, JJ
1667 LOGICAL :: CHECK_IRHS_loc
1668 INTEGER(8) :: DIFF_ADDR
1669 INCLUDE 'mumps_headers.h'
1670 CHECK_IRHS_loc=.FALSE.
1671 IF ( IRHS_loc_MEANINGFUL ) THEN
1672.GT. IF (Nloc_RHS 0) THEN
1673 CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1),
1674 & DIFF_ADDR )
1675.EQ. IF (DIFF_ADDR 0_8) THEN
1676 CHECK_IRHS_loc=.TRUE.
1677 ENDIF
1678 ENDIF
1679 ENDIF
1680 K=0
1681 DO ISTEP=1, KEEP(28)
1682 IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP),
1683 & KEEP(199))) THEN
1684 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
1685 & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N)
1686.eq..AND..EQ. IF (MTYPE1 KEEP(50)0) THEN
1687 J1=IPOS+1+LIELL
1688 ELSE
1689 J1=IPOS+1
1690 END IF
1691 DO JJ=J1,J1+NPIV-1
1692 K=K+1
1693 IF (CHECK_IRHS_loc) THEN
1694.LE. IF (KNloc_RHS) THEN
1695.NE. IF ( IW(JJ) IRHS_LOC(K) ) THEN
1696 ENDIF
1697 ENDIF
1698 ENDIF
1699 ISOL_LOC(K)=IW(JJ)
1700 IF (LSCAL) THEN
1701 scaling_data%SCALING_LOC(K)=
1702 & scaling_data%SCALING(IW(JJ))
1703 ENDIF
1704 ENDDO
1705 ENDIF
1706 ENDDO
1707 RETURN
1708 END SUBROUTINE DMUMPS_DISTSOL_INDICES
1709 SUBROUTINE DMUMPS_DISTRIBUTED_SOLUTION(
1710 & SLAVEF, N, MYID_NODES,
1711 & MTYPE, RHSCOMP, LRHSCOMP, NBRHS_EFF,
1712 & POSINRHSCOMP,
1713 & ISOL_LOC,
1714 & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC,
1715 & PTRIST,
1716 & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP,
1717 & scaling_data, LSCAL, NB_RHSSKIPPED,
1718 & PERM_RHS, SIZE_PERM_RHS)
1719 IMPLICIT NONE
1720 INCLUDE 'mpif.h'
1721 INCLUDE 'mumps_tags.h'
1722 type scaling_data_t
1723 SEQUENCE
1724 DOUBLE PRECISION, dimension(:), pointer :: SCALING
1725 DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC
1726 end type scaling_data_t
1727 TYPE (scaling_data_t) :: scaling_data
1728 LOGICAL LSCAL
1729 INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSCOMP
1730 INTEGER POSINRHSCOMP(N), NB_RHSSKIPPED
1731 INTEGER LSOL_LOC, BEG_RHS
1732 INTEGER ISOL_LOC(LSOL_LOC)
1733 INTEGER, INTENT(in) :: NRHS
1734 DOUBLE PRECISION SOL_LOC( LSOL_LOC, NRHS )
1735 DOUBLE PRECISION RHSCOMP( LRHSCOMP, NBRHS_EFF )
1736 INTEGER KEEP(500)
1737 INTEGER(8) KEEP8(150)
1738 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
1739 INTEGER IW(LIW), STEP(N)
1740 INTEGER, INTENT(in) :: SIZE_PERM_RHS
1741 INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS )
1742 INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSCOMP, JEMPTY
1743 INTEGER :: JCOL, JCOL_PERM
1744 INTEGER :: IPOS, LIELL, NPIV, JEND
1745 LOGICAL :: ROOT
1746!$ LOGICAL :: OMP_FLAG
1747 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0
1748 INCLUDE 'mumps_headers.h'
1749 INTEGER MUMPS_PROCNODE
1750 EXTERNAL MUMPS_PROCNODE
1751 K=0
1752 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1
1753 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1
1754 DO ISTEP = 1, KEEP(28)
1755 IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),
1756 & KEEP(199))) THEN
1757 ROOT=.false.
1758.ne. IF (KEEP(38)0) ROOT = STEP(KEEP(38))==ISTEP
1759.ne. IF (KEEP(20)0) ROOT = STEP(KEEP(20))==ISTEP
1760 IF ( ROOT ) THEN
1761 IPOS = PTRIST(ISTEP) + KEEP(IXSZ)
1762 LIELL = IW(IPOS+3)
1763 NPIV = LIELL
1764 IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ)
1765 ELSE
1766 IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ)
1767 LIELL = IW(IPOS-2)+IW(IPOS+1)
1768 IPOS= IPOS+1
1769 NPIV = IW(IPOS)
1770 IPOS= IPOS+1
1771 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ))
1772 END IF
1773.eq..AND..EQ. IF (MTYPE1 KEEP(50)0) THEN
1774 J1=IPOS+1+LIELL
1775 ELSE
1776 J1=IPOS+1
1777 END IF
1778.GT. IF (NB_RHSSKIPPED0) THEN
1779 DO JCOL = BEG_RHS, JEMPTY
1780.NE. IF (KEEP(242) 0) THEN
1781 JCOL_PERM = PERM_RHS(JCOL)
1782 ELSE
1783 JCOL_PERM = JCOL
1784 ENDIF
1785 KLOC=K
1786 DO JJ=J1,J1+NPIV-1
1787 KLOC=KLOC+1
1788 SOL_LOC(KLOC, JCOL_PERM) = ZERO
1789 ENDDO
1790 ENDDO
1791 ENDIF
1792.GE..AND.!$ OMP_FLAG = ( JEND-JEMPTYKEEP(362)
1793.GE.!$ & (NPIV*(JEND-JEMPTY) KEEP(363)/2 ) )
1794!$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSCOMP)
1795!$OMP& IF(OMP_FLAG)
1796 DO JCOL = JEMPTY+1, JEND
1797.NE. IF (KEEP(242) 0) THEN
1798 JCOL_PERM = PERM_RHS(JCOL)
1799 ELSE
1800 JCOL_PERM = JCOL
1801 ENDIF
1802 DO JJ=J1,J1+NPIV-1
1803 KLOC=K + JJ-J1 + 1
1804 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ))
1805 IF (LSCAL) THEN
1806 SOL_LOC(KLOC,JCOL_PERM) =
1807 & scaling_data%SCALING_LOC(KLOC)*
1808 & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY)
1809 ELSE
1810 SOL_LOC(KLOC,JCOL_PERM) =
1811 & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY)
1812 ENDIF
1813 ENDDO
1814 ENDDO
1815!$OMP END PARALLEL DO
1816 K=K+NPIV
1817 ENDIF
1818 ENDDO
1819 RETURN
1820 END SUBROUTINE DMUMPS_DISTRIBUTED_SOLUTION
1821 SUBROUTINE DMUMPS_SCATTER_RHS
1822 & (NSLAVES, N, MYID, COMM,
1823 & MTYPE, RHS, LRHS, NCOL_RHS, NRHS,
1824 & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP,
1825 & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP_F,
1826 & PTRIST,
1827 & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP,
1828 & ICNTL, INFO)
1829!$ USE OMP_LIB
1830 IMPLICIT NONE
1831 INCLUDE 'mpif.h'
1832 INCLUDE 'mumps_tags.h'
1833 INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE
1834 INTEGER NRHS, LRHS, NCOL_RHS, LRHSCOMP, NCOL_RHSCOMP
1835 INTEGER ICNTL(60), INFO(80)
1836 DOUBLE PRECISION, intent(in) :: RHS (LRHS, NCOL_RHS)
1837 DOUBLE PRECISION, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP)
1838 INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), NB_FS_IN_RHSCOMP_F
1839 INTEGER KEEP(500)
1840 INTEGER(8) KEEP8(150)
1841 INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
1842 INTEGER IW(LIW), STEP(N)
1843 INTEGER BUF_MAXSIZE, BUF_MAXREF
1844 PARAMETER (BUF_MAXREF=200000)
1845 INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX
1846 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS
1847 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2
1848 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE
1849 INTEGER INDX
1850 INTEGER allocok
1851 DOUBLE PRECISION ZERO
1852 PARAMETER( ZERO = 0.0D0 )
1853 INTEGER I, J, K, JJ, J1, ISTEP, MASTER,
1854 & MYID_NODES, TYPE_PARAL
1855 INTEGER LIELL, IPOS, NPIV
1856 INTEGER :: STATUS(MPI_STATUS_SIZE)
1857 INTEGER :: IERR
1858 PARAMETER(MASTER=0)
1859 LOGICAL I_AM_SLAVE
1860!$ INTEGER :: CHUNK, NOMP
1861!$ LOGICAL :: OMP_FLAG
1862 INCLUDE 'mumps_headers.h'
1863 INTEGER MUMPS_PROCNODE
1864 EXTERNAL MUMPS_PROCNODE
1865 TYPE_PARAL = KEEP(46)
1866.ne..OR..eq. I_AM_SLAVE = MYID 0 TYPE_PARAL 1
1867 IF ( TYPE_PARAL == 1 ) THEN
1868 MYID_NODES = MYID
1869 ELSE
1870 MYID_NODES = MYID-1
1871 ENDIF
1872 BUF_EFFSIZE = 0
1873 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000)
1874.EQ. IF ( KEEP(350)2 ) THEN
1875!$ NOMP = OMP_GET_MAX_THREADS()
1876 ALLOCATE (BUF_INDX(BUF_MAXSIZE),
1877 & BUF_RHS_2(BUF_MAXSIZE*NRHS),
1878 & stat=allocok)
1879 ELSE
1880 ALLOCATE (BUF_INDX(BUF_MAXSIZE),
1881 & BUF_RHS(NRHS,BUF_MAXSIZE),
1882 & stat=allocok)
1883 END IF
1884.GT. IF (allocok 0) THEN
1885 INFO(1)=-13
1886 INFO(2)=BUF_MAXSIZE*(NRHS+1)
1887 ENDIF
1888 CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID )
1889.LT. IF (INFO(1)0) RETURN
1890.EQ. IF (MYIDMASTER) THEN
1891 ENTRIES_2_PROCESS = N - KEEP(89)
1892.EQ..AND..NE. IF (TYPE_PARAL1ENTRIES_2_PROCESS0) THEN
1893.LT. IF (NB_FS_IN_RHSCOMP_FLRHSCOMP) THEN
1894 DO K=1, NCOL_RHSCOMP
1895 DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP
1896 RHSCOMP (I, K) = ZERO
1897 ENDDO
1898 ENDDO
1899 ENDIF
1900 ENDIF
1901.EQ. IF ( KEEP(350)2 ) THEN
1902.NE. DO WHILE ( ENTRIES_2_PROCESS 0)
1903 CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER,
1904 & MPI_ANY_SOURCE,
1905 & ScatterRhsI, COMM, STATUS, IERR )
1906 CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR)
1907 PROC_WHO_ASKS = STATUS(MPI_SOURCE)
1908!$ OMP_FLAG = .FALSE.
1909!$ CHUNK = NRHS
1910.GE.!$ IF (BUF_EFFSIZE*NRHS KEEP(363)) THEN
1911!$ OMP_FLAG = .TRUE.
1912!$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2)
1913!$ ENDIF
1914!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX)
1915!$OMP& IF (OMP_FLAG)
1916 DO K = 1, NRHS
1917 DO I = 1, BUF_EFFSIZE
1918 INDX = BUF_INDX( I )
1919 BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K )
1920 ENDDO
1921 ENDDO
1922!$OMP END PARALLEL DO
1923 CALL MPI_SEND( BUF_RHS_2,
1924 & NRHS*BUF_EFFSIZE,
1925 & MPI_DOUBLE_PRECISION, PROC_WHO_ASKS,
1926 & ScatterRhsR, COMM, IERR)
1927 ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE
1928 ENDDO
1929 BUF_EFFSIZE= 0
1930 ELSE
1931.NE. DO WHILE ( ENTRIES_2_PROCESS 0)
1932 CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER,
1933 & MPI_ANY_SOURCE,
1934 & ScatterRhsI, COMM, STATUS, IERR )
1935 CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR)
1936 PROC_WHO_ASKS = STATUS(MPI_SOURCE)
1937 DO I = 1, BUF_EFFSIZE
1938 INDX = BUF_INDX( I )
1939 DO K = 1, NRHS
1940 BUF_RHS( K, I ) = RHS( INDX, K )
1941 ENDDO
1942 ENDDO
1943 CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE,
1944 & MPI_DOUBLE_PRECISION, PROC_WHO_ASKS,
1945 & ScatterRhsR, COMM, IERR)
1946 ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE
1947 ENDDO
1948 BUF_EFFSIZE= 0
1949 ENDIF
1950 ENDIF
1951 IF (I_AM_SLAVE) THEN
1952.NE. IF (MYIDMASTER) THEN
1953.LT. IF (NB_FS_IN_RHSCOMP_FLRHSCOMP) THEN
1954 DO K=1, NCOL_RHSCOMP
1955 DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP
1956 RHSCOMP (I, K) = ZERO
1957 ENDDO
1958 ENDDO
1959 ENDIF
1960 ENDIF
1961 DO ISTEP = 1, KEEP(28)
1962 IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),
1963 & KEEP(199))) THEN
1964 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
1965 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
1966.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
1967 J1=IPOS+1
1968 ELSE
1969 J1=IPOS+1+LIELL
1970 END IF
1971.EQ. IF (MYIDMASTER) THEN
1972 INDX = POSINRHSCOMP_FWD(IW(J1))
1973.EQ..AND. IF (KEEP(350)2
1974.EQ..OR..GE. & (NRHS1((NPIV*NRHS*2*KEEP(16))KEEP(364)))) THEN
1975!$ OMP_FLAG = .FALSE.
1976!$ CHUNK = NRHS
1977.GE.!$ IF (NPIV*NRHS KEEP(363)) THEN
1978!$ OMP_FLAG = .TRUE.
1979!$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2)
1980!$ ENDIF
1981!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ)
1982!$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG)
1983 DO K = 1, NRHS
1984 DO JJ=J1,J1+NPIV-1
1985 J=IW(JJ)
1986 RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K )
1987 ENDDO
1988 ENDDO
1989!$OMP END PARALLEL DO
1990 ELSE
1991 DO JJ=J1,J1+NPIV-1
1992 J=IW(JJ)
1993 DO K = 1, NRHS
1994 RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K )
1995 ENDDO
1996 ENDDO
1997 END IF
1998 ELSE
1999 DO JJ=J1,J1+NPIV-1
2000 BUF_EFFSIZE = BUF_EFFSIZE + 1
2001 BUF_INDX(BUF_EFFSIZE) = IW(JJ)
2002.GT. IF (BUF_EFFSIZE + 1 BUF_MAXSIZE) THEN
2003 CALL DMUMPS_GET_BUF_INDX_RHS()
2004 ENDIF
2005 ENDDO
2006 ENDIF
2007 ENDIF
2008 ENDDO
2009.NE..AND..NE. IF ( BUF_EFFSIZE 0 MYIDMASTER )
2010 & CALL DMUMPS_GET_BUF_INDX_RHS()
2011 ENDIF
2012.EQ. IF (KEEP(350)2) THEN
2013 DEALLOCATE (BUF_INDX, BUF_RHS_2)
2014 ELSE
2015 DEALLOCATE (BUF_INDX, BUF_RHS)
2016 ENDIF
2017 RETURN
2018 CONTAINS
2019 SUBROUTINE DMUMPS_GET_BUF_INDX_RHS()
2020 CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER,
2021 & MASTER, ScatterRhsI, COMM, IERR )
2022.EQ. IF (KEEP(350)2) THEN
2023 CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS,
2024 & MPI_DOUBLE_PRECISION,
2025 & MASTER,
2026 & ScatterRhsR, COMM, STATUS, IERR )
2027!$ OMP_FLAG = .FALSE.
2028!$ CHUNK = NRHS
2029.GE.!$ IF (BUF_EFFSIZE*NRHS KEEP(363)) THEN
2030!$ OMP_FLAG = .TRUE.
2031!$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2)
2032!$ ENDIF
2033!$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX)
2034!$OMP& IF (OMP_FLAG)
2035 DO K = 1, NRHS
2036 DO I = 1, BUF_EFFSIZE
2037 INDX = POSINRHSCOMP_FWD(BUF_INDX(I))
2038 RHSCOMP( INDX, K ) =
2039 & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE)
2040 ENDDO
2041 ENDDO
2042!$OMP END PARALLEL DO
2043 ELSE
2044 CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS,
2045 & MPI_DOUBLE_PRECISION,
2046 & MASTER,
2047 & ScatterRhsR, COMM, STATUS, IERR )
2048 DO I = 1, BUF_EFFSIZE
2049 INDX = POSINRHSCOMP_FWD(BUF_INDX(I))
2050 DO K = 1, NRHS
2051 RHSCOMP( INDX, K ) = BUF_RHS( K, I )
2052 ENDDO
2053 ENDDO
2054 END IF
2055 BUF_EFFSIZE = 0
2056 RETURN
2057 END SUBROUTINE DMUMPS_GET_BUF_INDX_RHS
2058 END SUBROUTINE DMUMPS_SCATTER_RHS
2059 SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP
2060 & (NSLAVES, N, MYID_NODES,
2061 & PTRIST,
2062 & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP,
2063 & POSINRHSCOMP_ROW, POSINRHSCOMP_COL,
2064 & POSINRHSCOMP_COL_ALLOC,
2065 & MTYPE,
2066 & NBENT_RHSCOMP, NB_FS_IN_RHSCOMP )
2067 IMPLICIT NONE
2068 INCLUDE 'mpif.h'
2069 INCLUDE 'mumps_tags.h'
2070 INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW
2071 INTEGER, intent(in) :: KEEP(500)
2072 INTEGER(8), intent(in) :: KEEP8(150)
2073 INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
2074 INTEGER, intent(in) :: IW(LIW), STEP(N)
2075 INTEGER, intent(in) :: MTYPE
2076 LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC
2077 INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N)
2078 INTEGER, intent(out):: NBENT_RHSCOMP, NB_FS_IN_RHSCOMP
2079 INTEGER ISTEP
2080 INTEGER NPIV
2081 INTEGER IPOS, LIELL
2082 INTEGER JJ, J1, JCOL
2083 INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL
2084 INCLUDE 'mumps_headers.h'
2085 INTEGER MUMPS_PROCNODE
2086 EXTERNAL MUMPS_PROCNODE
2087 POSINRHSCOMP_ROW = 0
2088 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0
2089 IPOSINRHSCOMP = 1
2090 DO ISTEP = 1, KEEP(28)
2091 IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),
2092 & KEEP(199))) THEN
2093 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL,
2094 & IPOS, IW, LIW, PTRIST, STEP, N )
2095.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2096 J1=IPOS+1
2097 ELSE
2098 J1=IPOS+1+LIELL
2099 END IF
2100.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2101 JCOL = IPOS+1+LIELL
2102 ELSE
2103 JCOL = IPOS+1
2104 ENDIF
2105 DO JJ = J1, J1+NPIV-1
2106 POSINRHSCOMP_ROW(IW(JJ)) = IPOSINRHSCOMP+JJ-J1
2107 ENDDO
2108 IF (POSINRHSCOMP_COL_ALLOC) THEN
2109 DO JJ = JCOL, JCOL+NPIV-1
2110 POSINRHSCOMP_COL(IW(JJ)) = IPOSINRHSCOMP+JJ-JCOL
2111 ENDDO
2112 ENDIF
2113 IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV
2114 ENDIF
2115 ENDDO
2116 NB_FS_IN_RHSCOMP = IPOSINRHSCOMP -1
2117 IF (POSINRHSCOMP_COL_ALLOC) IPOSINRHSCOMP_COL=IPOSINRHSCOMP
2118.GT. IF (IPOSINRHSCOMPN) GOTO 500
2119 DO ISTEP = 1, KEEP(28)
2120 IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),
2121 & KEEP(199))) THEN
2122 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
2123 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
2124.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2125 J1=IPOS+1
2126 ELSE
2127 J1=IPOS+1+LIELL
2128 END IF
2129.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2130 JCOL = IPOS+1+LIELL
2131 ELSE
2132 JCOL = IPOS+1
2133 ENDIF
2134 IF (POSINRHSCOMP_COL_ALLOC) THEN
2135 DO JJ = NPIV, LIELL-1-KEEP(253)
2136.EQ. IF (POSINRHSCOMP_ROW(IW(J1+JJ))0) THEN
2137 POSINRHSCOMP_ROW(IW(J1+JJ)) = - IPOSINRHSCOMP
2138 IPOSINRHSCOMP = IPOSINRHSCOMP + 1
2139 ENDIF
2140.EQ. IF (POSINRHSCOMP_COL(IW(JCOL+JJ))0) THEN
2141 POSINRHSCOMP_COL(IW(JCOL+JJ)) = - IPOSINRHSCOMP_COL
2142 IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1
2143 ENDIF
2144 ENDDO
2145 ELSE
2146 DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253)
2147.EQ. IF (POSINRHSCOMP_ROW(IW(JJ))0) THEN
2148 POSINRHSCOMP_ROW(IW(JJ)) = - IPOSINRHSCOMP
2149 IPOSINRHSCOMP = IPOSINRHSCOMP + 1
2150 ENDIF
2151 ENDDO
2152 ENDIF
2153 ENDIF
2154 ENDDO
2155 500 NBENT_RHSCOMP = IPOSINRHSCOMP - 1
2156 IF (POSINRHSCOMP_COL_ALLOC)
2157 & NBENT_RHSCOMP = max(NBENT_RHSCOMP, IPOSINRHSCOMP_COL-1)
2158 RETURN
2159 END SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP
2160 SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP_AM1
2161 & (NSLAVES, N, MYID_NODES,
2162 & PTRIST, DAD,
2163 & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP,
2164 & POSINRHSCOMP_ROW, POSINRHSCOMP_COL,
2165 & POSINRHSCOMP_COL_ALLOC,
2166 & MTYPE,
2167 & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS,
2168 & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS,
2169 & NBENT_RHSCOMP,
2170 & NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT,
2171 & UNS_PERM_INV, SIZE_UNS_PERM_INV
2172 & )
2173 IMPLICIT NONE
2174 INCLUDE 'mpif.h'
2175 INCLUDE 'mumps_tags.h'
2176 INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW,
2177 & SIZE_UNS_PERM_INV
2178 INTEGER, intent(in) :: KEEP(500)
2179 INTEGER(8), intent(in) :: KEEP8(150)
2180 INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28))
2181 INTEGER, intent(inout) :: DAD(KEEP(28))
2182 INTEGER, intent(in) :: IW(LIW), STEP(N)
2183 INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1)
2184 INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS)
2185 INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS)
2186 INTEGER, intent(in) :: JBEG_RHS
2187 INTEGER, intent(in) :: MTYPE
2188 LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC
2189 INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N)
2190 INTEGER, intent(out):: NBENT_RHSCOMP
2191 INTEGER, intent(out):: NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT
2192 INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV)
2193 INTEGER I, JAM1
2194 INTEGER ISTEP, OLDISTEP
2195 INTEGER NPIV
2196 INTEGER IPOS, LIELL
2197 INTEGER JJ, J1, JCOL, ABSJCOL
2198 INTEGER IPOSINRHSCOMP_ROW, IPOSINRHSCOMP_COL
2199 INTEGER NBENT_RHSCOMP_ROW, NBENT_RHSCOMP_COL
2200 LOGICAL GO_UP
2201 INCLUDE 'mumps_headers.h'
2202 INTEGER MUMPS_PROCNODE
2203 EXTERNAL MUMPS_PROCNODE
2204.EQ. IF(KEEP(237)0) THEN
2205 WRITE(*,*)'BUILD_POSINRHSCOMP_SPARSE available for A-1 only !'
2206 CALL MUMPS_ABORT()
2207 END IF
2208 POSINRHSCOMP_ROW = 0
2209 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0
2210 IPOSINRHSCOMP_ROW = 0
2211 IPOSINRHSCOMP_COL = 0
2212 DO I = 1, NBCOL_INBLOC
2213.EQ. IF ((IRHS_PTR(I+1)-IRHS_PTR(I))0) CYCLE
2214.NE. IF (KEEP(242)0) THEN
2215 JAM1 = PERM_RHS(JBEG_RHS+I-1)
2216 ELSE
2217 JAM1 = JBEG_RHS+I-1
2218 END IF
2219 ISTEP = abs(STEP(JAM1))
2220 GO_UP = .TRUE.
2221 DO WHILE(GO_UP)
2222.EQ. IF(MYID_NODES
2223 & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN
2224 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
2225 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
2226.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2227 J1=IPOS+1
2228 ELSE
2229 J1=IPOS+1+LIELL
2230 END IF
2231.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2232 JCOL = IPOS+1+LIELL
2233 ELSE
2234 JCOL = IPOS+1
2235 ENDIF
2236.GT. IF(NPIV0) THEN
2237.EQ. IF(POSINRHSCOMP_ROW(IW(J1))0) THEN
2238 DO JJ = J1, J1+NPIV-1
2239 POSINRHSCOMP_ROW(IW(JJ))
2240 & = IPOSINRHSCOMP_ROW + JJ - J1 + 1
2241 ENDDO
2242 IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + NPIV
2243 IF (POSINRHSCOMP_COL_ALLOC) THEN
2244 DO JJ = JCOL, JCOL+NPIV-1
2245 POSINRHSCOMP_COL(IW(JJ))
2246 & = - N - (IPOSINRHSCOMP_COL + JJ - JCOL + 1)
2247 ENDDO
2248 IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV
2249 ENDIF
2250 ELSE
2251 GO_UP = .FALSE.
2252 END IF
2253 END IF
2254 END IF
2255.NE. IF(DAD(ISTEP)0) THEN
2256 ISTEP = STEP(DAD(ISTEP))
2257 ELSE
2258 GO_UP = .FALSE.
2259 END IF
2260 END DO
2261 END DO
2262 NB_FS_IN_RHSCOMP_FWD = IPOSINRHSCOMP_ROW
2263 IF(POSINRHSCOMP_COL_ALLOC) THEN
2264 DO I =1, NZ_RHS
2265 JAM1 = IRHS_SPARSE(I)
2266.NE. IF (KEEP(23)0) JAM1 = UNS_PERM_INV(JAM1)
2267 ISTEP = abs(STEP(JAM1))
2268 GO_UP = .TRUE.
2269 DO WHILE(GO_UP)
2270.EQ. IF(MYID_NODES
2271 & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN
2272 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
2273 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
2274.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2275 J1=IPOS+1
2276 ELSE
2277 J1=IPOS+1+LIELL
2278 END IF
2279.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2280 JCOL = IPOS+1+LIELL
2281 ELSE
2282 JCOL = IPOS+1
2283 ENDIF
2284 ABSJCOL = abs(IW(JCOL))
2285.GT. IF(NPIV0) THEN
2286.EQ. IF(POSINRHSCOMP_COL(ABSJCOL)0) THEN
2287 DO JJ = JCOL, JCOL+NPIV-1
2288 POSINRHSCOMP_COL(abs(IW(JJ))) =
2289 & IPOSINRHSCOMP_COL+JJ-JCOL+1
2290 END DO
2291 IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV
2292.LT. ELSE IF (POSINRHSCOMP_COL(ABSJCOL)-N) THEN
2293 DO JJ = JCOL, JCOL+NPIV-1
2294 POSINRHSCOMP_COL(abs(IW(JJ)))=
2295 & -(N+POSINRHSCOMP_COL(abs(IW(JJ))))
2296 END DO
2297.LT..AND. ELSE IF ((POSINRHSCOMP_COL(ABSJCOL)0)
2298.GE. & (POSINRHSCOMP_COL(ABSJCOL)-N))THEN
2299 WRITE(*,*)'Internal error 7 in BUILD...SPARSE'
2300 CALL MUMPS_ABORT()
2301 ELSE
2302 GO_UP = .FALSE.
2303 END IF
2304 END IF
2305 END IF
2306.NE. IF(DAD(ISTEP)0) THEN
2307 ISTEP = STEP(DAD(ISTEP))
2308 ELSE
2309 GO_UP = .FALSE.
2310 END IF
2311 END DO
2312 END DO
2313 END IF
2314 NB_FS_IN_RHSCOMP_TOT = IPOSINRHSCOMP_COL
2315.NE. IF (NSLAVES1) THEN
2316 DO I = 1, NBCOL_INBLOC
2317.EQ. IF ((IRHS_PTR(I+1)-IRHS_PTR(I))0) CYCLE
2318.NE. IF (KEEP(242)0) THEN
2319 JAM1 = PERM_RHS(JBEG_RHS+I-1)
2320 ELSE
2321 JAM1 = JBEG_RHS+I-1
2322 END IF
2323 ISTEP = abs(STEP(JAM1))
2324 GO_UP = .TRUE.
2325 DO WHILE(GO_UP)
2326.EQ. IF(MYID_NODES
2327 & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN
2328 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
2329 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
2330.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2331 J1=IPOS+1
2332 ELSE
2333 J1=IPOS+1+LIELL
2334 END IF
2335.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2336 JCOL = IPOS+1+LIELL
2337 ELSE
2338 JCOL = IPOS+1
2339 ENDIF
2340 DO JJ = NPIV, LIELL-1-KEEP(253)
2341.EQ. IF(POSINRHSCOMP_ROW(IW(J1+JJ))0) THEN
2342 IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + 1
2343 POSINRHSCOMP_ROW(IW(JJ+J1))
2344 & = -IPOSINRHSCOMP_ROW
2345 END IF
2346 END DO
2347 END IF
2348.GT. IF(DAD(ISTEP)0) THEN
2349 OLDISTEP=ISTEP
2350 ISTEP = STEP(DAD(ISTEP))
2351 DAD(OLDISTEP)=-DAD(OLDISTEP)
2352 ELSE
2353 GO_UP = .FALSE.
2354 END IF
2355 END DO
2356 END DO
2357 DAD=ABS(DAD)
2358 IF(POSINRHSCOMP_COL_ALLOC) THEN
2359 DO I =1, NZ_RHS
2360 JAM1 = IRHS_SPARSE(I)
2361.NE. IF (KEEP(23)0) JAM1 = UNS_PERM_INV(JAM1)
2362 ISTEP = abs(STEP(JAM1))
2363 GO_UP = .TRUE.
2364 DO WHILE(GO_UP)
2365.EQ. IF(MYID_NODES
2366 & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN
2367 CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP,
2368 & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
2369.eq..OR..NE. IF (MTYPE1 KEEP(50)0) THEN
2370 J1=IPOS+1
2371 ELSE
2372 J1=IPOS+1+LIELL
2373 END IF
2374.EQ..AND..EQ. IF ( MTYPE 1 KEEP(50)0 ) THEN
2375 JCOL = IPOS+1+LIELL
2376 ELSE
2377 JCOL = IPOS+1
2378 ENDIF
2379.NE. IF (KEEP(23)0) JAM1 = UNS_PERM_INV(JAM1)
2380 DO JJ = NPIV, LIELL-1-KEEP(253)
2381.EQ. IF(POSINRHSCOMP_COL(IW(JCOL+JJ))0) THEN
2382 IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1
2383 POSINRHSCOMP_COL(IW(JCOL+JJ))
2384 & = -IPOSINRHSCOMP_COL
2385.LT. ELSE IF (POSINRHSCOMP_COL(IW(JCOL+JJ))-N) THEN
2386 IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1
2387 POSINRHSCOMP_COL(IW(JCOL+JJ))
2388 & = POSINRHSCOMP_COL(IW(JCOL+JJ)) + N
2389 END IF
2390 END DO
2391 END IF
2392.GT. IF(DAD(ISTEP)0) THEN
2393 OLDISTEP=ISTEP
2394 ISTEP = STEP(DAD(ISTEP))
2395 DAD(OLDISTEP)=-DAD(OLDISTEP)
2396 ELSE
2397 GO_UP = .FALSE.
2398 END IF
2399 END DO
2400 END DO
2401 DAD=ABS(DAD)
2402 END IF
2403 ENDIF
2404 NBENT_RHSCOMP_ROW = IPOSINRHSCOMP_ROW
2405 NBENT_RHSCOMP_COL = IPOSINRHSCOMP_COL
2406 NBENT_RHSCOMP = max(NBENT_RHSCOMP_ROW,NBENT_RHSCOMP_COL)
2407 RETURN
2408 END SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP_AM1
dmumps_gather_solution
subroutine dmumps_gather_solution(nslaves, n, myid, comm, nrhs, mtype, rhs, lrhs, ncol_rhs, jbeg_rhs, ptrist, keep, keep8, procnode_steps, iw, liw, step, buffer, size_buf, size_buf_bytes, cwork, lcwork, lscal, scaling, lscaling, rhscomp, lrhscomp, ncol_rhscomp, posinrhscomp, lpos_n, perm_rhs, size_perm_rhs)
Definition dsol_c.F:1083
dmumps_sol_c
subroutine dmumps_sol_c(root, n, a, la, iw, liw, w, lwc, iwcb, liww, nrhs, na, lna, ne_steps, w2, mtype, icntl, from_pp, step, frere, dad, fils, ptrist, ptrfac, iw1, liw1, ptracb, liwk_ptracb, procnode_steps, slavef, info, keep, keep8, dkeep, comm_nodes, myid, myid_nodes, bufr, lbufr, lbufr_bytes, istep_to_iniv2, tab_pos_in_pere, ibeg_root_def, iend_root_def, iroot_def_rhs_col1, rhs_root, lrhs_root, size_root, master_root, rhscomp, lrhscomp, posinrhscomp_fwd, posinrhscomp_bwd, nz_rhs, nbcol_inbloc, nrhs_orig, jbeg_rhs, step2node, lstep2node, irhs_sparse, irhs_ptr, size_perm_rhs, perm_rhs, size_uns_perm_inv, uns_perm_inv, nb_fs_in_rhscomp_f, nb_fs_in_rhscomp_tot, do_nbsparse, rhs_bounds, lrhs_bounds, ipool_b_l0_omp, lpool_b_l0_omp, ipool_a_l0_omp, lpool_a_l0_omp, l_virt_l0_omp, virt_l0_omp, l_phys_l0_omp, phys_l0_omp, perm_l0_omp, ptr_leafs_l0_omp, l0_omp_mapping, ll0_omp_mapping, l0_omp_factors, ll0_omp_factors)
Definition dsol_c.F:31
max
#define max(a, b)
Definition macros.h:21
dmumps_ooc
Definition dmumps_ooc.F:14
dmumps_sol_es
Definition dmumps_sol_es.F:14
dmumps_sol_l0omp_m
Definition dsol_omp_m.F:14
dmumps_sol_l0omp_m::dmumps_sol_l0omp_s
subroutine dmumps_sol_l0omp_s(n, mtype, nrhs, liw, iw, ptricb, ptracb, rhscomp, lrhscomp, posinrhscomp_bwd, step, frere, fils, ne_steps, ptrist, ptrfac, info, keep, keep8, dkeep, procnode_steps, slavef, comm, myid, bufr, lbufr, lbufr_bytes, rhs_root, lrhs_root, istep_to_iniv2, tab_pos_in_pere, panel_pos, lpanel_pos, prun_below_bwd, to_process, size_to_process, rhs_bounds, lrhs_bounds, do_nbsparse, from_pp, lpool_b_l0_omp, l_virt_l0_omp, virt_l0_omp, l_phys_l0_omp, phys_l0_omp, perm_l0_omp, ptr_leafs_l0_omp, l0_omp_mapping, ll0_omp_mapping, l0_omp_factors, ll0_omp_factors)
Definition dsol_omp_m.F:299
dmumps_sol_l0omp_m::dmumps_sol_l0omp_r
subroutine dmumps_sol_l0omp_r(n, mtype, nrhs, liw, iw, ptricb, rhscomp, lrhscomp, posinrhscomp_fwd, step, frere, dad, fils, nstk, ptrist, ptrfac, info, keep, keep8, dkeep, procnode_steps, slavef, comm, myid, bufr, lbufr, lbufr_bytes, rhs_root, lrhs_root, istep_to_iniv2, tab_pos_in_pere, rhs_bounds, lrhs_bounds, do_nbsparse, from_pp, nbroot_under_l0, lpool_b_l0_omp, ipool_b_l0_omp, l_virt_l0_omp, virt_l0_omp, l_phys_l0_omp, phys_l0_omp, perm_l0_omp, ptr_leafs_l0_omp, l0_omp_mapping, ll0_omp_mapping, l0_omp_factors, ll0_omp_factors, do_prun, to_process)
Definition dsol_omp_m.F:62
dmumps_struc_def
Definition dmumps_struc_def.F:14
mumps_secdeb
subroutine mumps_secdeb(t)
Definition tools_common.F:270