OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sfac_process_blocfacto.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 RECURSIVE SUBROUTINE smumps_process_blocfacto(
15 & COMM_LOAD, ASS_IRECV,
16 & BUFR, LBUFR,
17 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU,
18 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW,
19 & A, LA, PTRIST, PTRAST, NSTK_S, PERM,
20 & COMP, STEP, PIMASTER, PAMASTER, POSFAC,
21 & MYID, COMM, IFLAG, IERROR, NBFIN,
22 &
23 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW,
24 & ITLOC, RHS_MUMPS, FILS, DAD,
25 & PTRARW, PTRAIW, INTARR, DBLARR,
26 & ICNTL, KEEP,KEEP8, DKEEP,
27 & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS,
28 & LPTRAR, NELT, FRTPTR, FRTELT,
29 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
30 & , LRGROUPS
31 & )
32 USE smumps_ooc, ONLY : io_block
33 USE mumps_ooc_common, ONLY : typef_l, strat_try_write
34 USE smumps_load
35 USE smumps_lr_core
36 USE smumps_lr_type
37 USE smumps_lr_stats
38 USE smumps_fac_lr
39 USE smumps_ana_lr, ONLY : get_cut
40 USE smumps_lr_data_m
41 USE smumps_struc_def, ONLY : smumps_root_struc
42 USE smumps_dynamic_memory_m, ONLY : smumps_dm_set_dynptr
43!$ USE OMP_LIB
44 IMPLICIT NONE
45 include 'mumps_headers.h'
46 TYPE (smumps_root_struc) :: root
47 INTEGER icntl( 60 ), keep( 500 )
48 INTEGER(8) keep8(150)
49 REAL dkeep(230)
50 INTEGER lbufr, lbufr_bytes
51 INTEGER comm_load, ass_irecv
52 INTEGER bufr( lbufr )
53 INTEGER n, slavef, iwpos, iwposcb, liw
54 INTEGER(8) :: iptrlu, lrlu, lrlus, la
55 INTEGER(8) :: posfac
56 INTEGER comp
57 INTEGER iflag, ierror, nbfin, msgsou
58 INTEGER procnode_steps(keep(28)), ptrist(keep(28)),
59 & nstk_s(keep(28))
60 INTEGER(8) :: pamaster(keep(28))
61 INTEGER(8) :: ptrast(keep(28))
62 INTEGER(8) :: ptrfac(keep(28))
63 INTEGER perm(n), step(n),
64 & pimaster(keep(28))
65 INTEGER IW( liw )
66 REAL a( la )
67 INTEGER, intent(in) :: lrgroups(n)
68 INTEGER comm, myid
69 INTEGER nelt, lptrar
70 INTEGER frtptr( n+1 ), frtelt( nelt )
71 INTEGER ptlust_s(keep(28)),
72 & itloc(n+keep(253)), fils(n), dad(keep(28)), nd(keep(28))
73 REAL :: rhs_mumps(keep(255))
74 INTEGER(8), INTENT(IN) :: PTRAIW( lptrar ), ptrarw( lptrar )
75 INTEGER frere_steps(keep(28))
76 DOUBLE PRECISION opassw, opeliw
77 DOUBLE PRECISION flop1
78 INTEGER intarr( keep8(27) )
79 REAL dblarr( keep8(26) )
80 INTEGER leaf, lpool
81 INTEGER ipool( lpool )
82 INTEGER istep_to_iniv2(keep(71)),
83 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
84 include 'mpif.h'
85 INCLUDE 'mumps_tags.h'
86 INTEGER :: STATUS(MPI_STATUS_SIZE)
87 LOGICAL :: I_HAVE_SET_K117
88 INTEGER INODE, POSITION, NPIV, IERR, LP
89 INTEGER NCOL
90 INTEGER(8) :: POSBLOCFACTO
91 INTEGER :: LD_BLOCFACTO
92 INTEGER(8) :: LA_BLOCFACTO
93 INTEGER(8) :: LA_PTR
94 INTEGER(8) :: POSELT
95 REAL, DIMENSION(:), POINTER :: A_PTR
96 INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1
97 INTEGER NSLAV1, HS, ISW
98 INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS
99 INTEGER ICT11
100 INTEGER I, IPIV, FPERE
101 LOGICAL LASTBL, KEEP_BEGS_BLR_L
102 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
103 REAL ONE,ALPHA
104 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0)
105 INTEGER LIWFAC, STRAT, NextPivDummy
106 TYPE(IO_BLOCK) :: MonBloc
107 LOGICAL LAST_CALL
108 INTEGER LRELAY_INFO
109 INTEGER :: INFO_TMP(2)
110 INTEGER :: IDUMMY(1)
111 INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX,
112 & IPANEL,
113 & CURRENT_BLR,
114 & NB_BLR_L, NB_BLR_U, NB_BLR_COL
115 TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB
116 TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L
117 LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL
118 LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR
119 INTEGER :: LR_ACTIVATED_INT
120 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U,
121 & BEGS_BLR_COL
122 REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU
123 INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT
124 REAL,ALLOCATABLE,DIMENSION(:) :: RWORK
125 REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCK
126 INTEGER :: OMP_NUM
127 INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK,
128 & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL
129 INTEGER :: allocok
130 INTEGER MUMPS_PROCNODE
131 EXTERNAL MUMPS_PROCNODE
132 KEEP_BEGS_BLR_L = .FALSE.
133 nullify(BEGS_BLR_L)
134 NB_BLR_U = -7654321
135 NULLIFY(BEGS_BLR_U)
136 I_HAVE_SET_K117 = .FALSE.
137 FPERE = -1
138 POSITION = 0
139 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1,
140 & MPI_INTEGER, COMM, IERR )
141 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1,
142 & MPI_INTEGER, COMM, IERR )
143.LE. LASTBL = (NPIV0)
144 IF (LASTBL) THEN
145 NPIV = -NPIV
146 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1,
147 & MPI_INTEGER, COMM, IERR )
148 ENDIF
149 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1,
150 & MPI_INTEGER, COMM, IERR )
151 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1,
152 & MPI_INTEGER, COMM, IERR )
153 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
154 & NPARTSASS_MASTER , 1,
155 & MPI_INTEGER, COMM, IERR )
156 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL,
157 & 1, MPI_INTEGER, COMM, IERR )
158 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT,
159 & 1, MPI_INTEGER, COMM, IERR )
160.EQ. LR_ACTIVATED = (LR_ACTIVATED_INT1)
161 IF ( LR_ACTIVATED ) THEN
162 LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8)
163 ELSE
164 LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8)
165 ENDIF
166 CALL SMUMPS_GET_SIZE_NEEDED(
167 & NPIV, LA_BLOCFACTO, .FALSE.,
168 & KEEP(1), KEEP8(1),
169 & N, IW, LIW, A, LA,
170 & LRLU, IPTRLU,
171 & IWPOS, IWPOSCB, PTRIST, PTRAST,
172 & STEP, PIMASTER, PAMASTER, LRLUS,
173 & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS,
174 & DAD, IFLAG, IERROR)
175.LT. IF (IFLAG0) GOTO 700
176 LRLU = LRLU - LA_BLOCFACTO
177 LRLUS = LRLUS - LA_BLOCFACTO
178 KEEP8(67) = min(LRLUS, KEEP8(67))
179 KEEP8(69) = KEEP8(69) + LA_BLOCFACTO
180 KEEP8(68) = max(KEEP8(69), KEEP8(68))
181 POSBLOCFACTO = POSFAC
182 POSFAC = POSFAC + LA_BLOCFACTO
183 CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE.,
184 & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
185.EQ. IF ((NPIV 0)
186 & ) THEN
187 IPIV=1
188 ELSE
189 IPIV = IWPOS
190 IWPOS = IWPOS + NPIV
191.GT. IF (NPIV 0) THEN
192 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
193 & IW( IPIV ), NPIV,
194 & MPI_INTEGER, COMM, IERR )
195 ENDIF
196 IF ( LR_ACTIVATED ) THEN
197 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
198 & A(POSBLOCFACTO), NPIV*(NPIV+NELIM),
199 & MPI_REAL,
200 & COMM, IERR )
201 LD_BLOCFACTO = NPIV+NELIM
202 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
203 & NB_BLR_U, 1, MPI_INTEGER,
204 & COMM, IERR )
205 ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok)
206 IF (allocok > 0 ) THEN
207 IFLAG = -13
208 IERROR = max(NB_BLR_U,1)
209 LP = ICNTL(1)
210.LE. IF (ICNTL(4) 0) LP=-1
211 IF (LP > 0) WRITE(LP,*) MYID,
212 & ': error allocation during smumps_process_blocfacto'
213 GOTO 700
214 ENDIF
215 ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok)
216 IF (allocok > 0 ) THEN
217 IFLAG = -13
218 IERROR = NB_BLR_U+2
219 LP = ICNTL(1)
220.LE. IF (ICNTL(4) 0) LP=-1
221 IF (LP > 0) WRITE(LP,*) MYID,
222 & ': error allocation during smumps_process_blocfacto'
223 GOTO 700
224 ENDIF
225 CALL SMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES,
226 & POSITION, NPIV, NELIM, 'h',
227 & BLR_U(1), NB_BLR_U,
228 & BEGS_BLR_U(1),
229 & KEEP8, COMM, IERR, IFLAG, IERROR)
230.LT. IF (IFLAG0) GOTO 700
231 ELSE
232 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
233 & A(POSBLOCFACTO), NPIV*NCOL,
234 & MPI_REAL,
235 & COMM, IERR )
236 LD_BLOCFACTO = NCOL
237 ENDIF
238 ENDIF
239 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
240 & LRELAY_INFO, 1,
241 & MPI_INTEGER, COMM, IERR )
242.EQ. IF (PTRIST(STEP( INODE )) 0) THEN
243 CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD,
244 & ASS_IRECV,
245 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
246 & IWPOS, IWPOSCB, IPTRLU,
247 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
248 & PTLUST_S, PTRFAC,
249 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
250 & IFLAG, IERROR, COMM,
251 & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
252 &
253 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
254 & FILS, DAD, PTRARW, PTRAIW,
255 & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
256 & LPTRAR, NELT, FRTPTR, FRTELT,
257 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.
258 & , LRGROUPS
259 & )
260.LT. IF ( IFLAG 0 ) GOTO 600
261 ENDIF
262.EQ. IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) 0 ) THEN
263.NE. DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) 0)
264 BLOCKING = .TRUE.
265 SET_IRECV = .FALSE.
266 MESSAGE_RECEIVED = .FALSE.
267 CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD,
268 & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
269 & MPI_ANY_SOURCE, CONTRIB_TYPE2,
270 & STATUS,
271 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
272 & IWPOS, IWPOSCB, IPTRLU,
273 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
274 & PTLUST_S, PTRFAC,
275 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
276 & IFLAG, IERROR, COMM,
277 & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
278 &
279 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
280 & FILS, DAD, PTRARW, PTRAIW,
281 & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
282 & LPTRAR, NELT, FRTPTR, FRTELT,
283 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.
284 & , LRGROUPS
285 & )
286.LT. IF ( IFLAG 0 ) GOTO 600
287 END DO
288 ENDIF
289 SET_IRECV = .TRUE.
290 BLOCKING = .FALSE.
291 MESSAGE_RECEIVED = .TRUE.
292 CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV,
293 & BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
294 & MPI_ANY_SOURCE, MPI_ANY_TAG,
295 & STATUS,
296 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
297 & IWPOS, IWPOSCB, IPTRLU,
298 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
299 & PTLUST_S, PTRFAC,
300 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
301 & IFLAG, IERROR, COMM,
302 & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
303 &
304 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
305 & FILS, DAD, PTRARW, PTRAIW,
306 & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
307 & LPTRAR, NELT, FRTPTR, FRTELT,
308 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.
309 & , LRGROUPS
310 & )
311 IOLDPS = PTRIST(STEP(INODE))
312 CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA,
313 & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR),
314 & A_PTR, POSELT, LA_PTR )
315 LCONT1 = IW( IOLDPS + KEEP(IXSZ))
316 NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ))
317.GE. COMPRESS_PANEL = (IW(IOLDPS+XXLR)2)
318 OOCWRITE_COMPATIBLE_WITH_BLR =
319.NOT..OR..NOT..OR. & ( LR_ACTIVATED (COMPRESS_PANEL)
320.NE. & (KEEP(486)2)
321 & )
322 IF ( NASS1 < 0 ) THEN
323 NASS1 = -NASS1
324 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1
325.EQ. IF (KEEP(55) 0) THEN
326 CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW,
327 & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC,
328 & FILS, PTRAIW,
329 & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS,
330 & LRGROUPS)
331 ELSE
332 CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW,
333 & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC,
334 & FILS, PTRAIW,
335 & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26),
336 & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS)
337 ENDIF
338 ENDIF
339 NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ))
340 NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ))
341 NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ))
342 HS = 6 + NSLAV1 + KEEP(IXSZ)
343 NCOL1 = LCONT1 + NPIV1
344.GT. IF (NPIV0) THEN
345 ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1
346 DO I = 1, NPIV
347.EQ. IF (IW(IPIV+I-1)I) CYCLE
348 ISW = IW(ICT11+I)
349 IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1))
350 IW(ICT11+IW(IPIV+I-1)) = ISW
351 IPOS = POSELT + int(NPIV1 + I - 1,8)
352 KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8)
353 CALL sswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1)
354 ENDDO
355 LPOS2 = POSELT + int(NPIV1,8)
356 LPOS = LPOS2 + int(NPIV,8)
357.NOT..OR..EQ. IF (( LR_ACTIVATED)KEEP(475)0) THEN
358 CALL strsm('l','l','n','n', NPIV, NROW1, ONE,
359 & A(POSBLOCFACTO), LD_BLOCFACTO,
360 & A_PTR(LPOS2), NCOL1)
361 ENDIF
362 ENDIF
363 COMPRESS_CB = .FALSE.
364 IF ( LR_ACTIVATED) THEN
365.EQ..OR. COMPRESS_CB = ((IW(IOLDPS+XXLR)1)
366.EQ. & (IW(IOLDPS+XXLR)3))
367.AND..EQ. IF (COMPRESS_CBNPIV0) THEN
368 COMPRESS_CB = .FALSE.
369 IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1
370 ENDIF
371.NE. IF (NPIV0) THEN
372.EQ. IF ( (NPIV10)
373 & ) THEN
374 IOLDPS = PTRIST(STEP(INODE))
375 CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0,
376 & NROW1, LRGROUPS, NPARTSCB,
377 & NPARTSASS, BEGS_BLR_L)
378 CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, 0, NPARTSCB,
379 & NROW1-0, KEEP(488), .TRUE., KEEP(472))
380 NB_BLR_L = NPARTSCB
381.EQ. IF (IPANEL1) THEN
382 BEGS_BLR_COL=>BEGS_BLR_U
383 ELSE
384 ALLOCATE(BEGS_BLR_COL(size(BEGS_BLR_U)+IPANEL-1),
385 & stat=allocok)
386 IF (allocok > 0 ) THEN
387 IFLAG = -13
388 IERROR = size(BEGS_BLR_U)+IPANEL-1
389 LP = ICNTL(1)
390.LE. IF (ICNTL(4) 0) LP=-1
391 IF (LP > 0) WRITE(LP,*) MYID,
392 & ': error allocation during smumps_process_blocfacto'
393 GOTO 700
394 ENDIF
395 BEGS_BLR_COL(1:IPANEL-1) = 1
396 DO I=1,size(BEGS_BLR_U)
397 BEGS_BLR_COL(IPANEL+I-1) = BEGS_BLR_U(I)
398 ENDDO
399 ENDIF
400 INFO_TMP(1) = IFLAG
401 INFO_TMP(2) = IERROR
402.LT. IF (IFLAG0) GOTO 700
403 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF),
404 & .FALSE.,
405 & .TRUE.,
406 & .TRUE.,
407 & NPARTSASS_MASTER,
408 & BEGS_BLR_L,
409 & BEGS_BLR_COL,
410 & huge(NPARTSASS_MASTER),
411 & INFO_TMP)
412 IFLAG = INFO_TMP(1)
413 IERROR = INFO_TMP(2)
414.NE. IF (IPANEL1) THEN
415 DEALLOCATE(BEGS_BLR_COL)
416 ENDIF
417.LT. IF (IFLAG0) GOTO 700
418 ELSE
419 CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF),
420 & BEGS_BLR_L)
421 KEEP_BEGS_BLR_L = .TRUE.
422 NB_BLR_L = size(BEGS_BLR_L) - 2
423 NPARTSASS = 1
424 NPARTSCB = NB_BLR_L
425 ENDIF
426 ENDIF
427 ENDIF
428.GT. IF ( (NPIV 0)
429 & ) THEN
430 IF (LR_ACTIVATED) THEN
431 call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L)
432 call MAX_CLUSTER(BEGS_BLR_U,NB_BLR_U+1,MAXI_CLUSTER_U)
433.AND. IF (LASTBLCOMPRESS_CB) THEN
434 MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L)
435 ELSE
436 MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L)
437 ENDIF
438 LWORK = MAXI_CLUSTER*MAXI_CLUSTER
439 OMP_NUM = 1
440#if defined(BLR_MT)
441!$ OMP_NUM = OMP_GET_MAX_THREADS()
442#endif
443 ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER),
444 & RWORK(2*MAXI_CLUSTER*OMP_NUM),
445 & TAU(MAXI_CLUSTER*OMP_NUM),
446 & JPVT(MAXI_CLUSTER*OMP_NUM),
447 & WORK(LWORK*OMP_NUM), stat=allocok)
448 IF (allocok > 0 ) THEN
449 IFLAG = -13
450 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER
451 & + 2*MAXI_CLUSTER*OMP_NUM
452 & + MAXI_CLUSTER*OMP_NUM
453 & + MAXI_CLUSTER*OMP_NUM
454 & + LWORK*OMP_NUM
455 LP = ICNTL(1)
456.LE. IF (ICNTL(4) 0) LP=-1
457 IF (LP > 0) WRITE(LP,*) MYID,
458 & ': error allocation during smumps_process_blocfacto'
459 GOTO 700
460 ENDIF
461 CURRENT_BLR=1
462 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok)
463 IF (allocok > 0 ) THEN
464 IFLAG = -13
465 IERROR = NB_BLR_L
466 LP = ICNTL(1)
467.LE. IF (ICNTL(4) 0) LP=-1
468 IF (LP > 0) WRITE(LP,*) MYID,
469 & ': error allocation during smumps_process_blocfacto'
470 GOTO 700
471 ENDIF
472#if defined(BLR_MT)
473!$OMP PARALLEL
474#endif
475 CALL SMUMPS_COMPRESS_PANEL_I_NOOPT
476 & (A_PTR(POSELT), LA_PTR, 1_8,
477 & IFLAG, IERROR, NCOL1,
478 & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1,
479 & DKEEP(8), KEEP(466), KEEP(473),
480 & BLR_L(1),
481 & CURRENT_BLR, 'v', WORK, TAU, JPVT, LWORK, RWORK,
482 & BLOCK, MAXI_CLUSTER, NELIM,
483 & .TRUE.,
484 & NPIV, NPIV1,
485 & 2, KEEP(483), KEEP8,
486 & OMP_NUM )
487#if defined(BLR_MT)
488!$OMP MASTER
489#endif
490.EQ. IF ( (KEEP(486)2)
491 & ) THEN
492 CALL SMUMPS_BLR_SAVE_PANEL_LORU (
493 & IW(IOLDPS+XXF),
494 & 0,
495 & IPANEL, BLR_L)
496 ENDIF
497#if defined(BLR_MT)
498!$OMP END MASTER
499!$OMP BARRIER
500#endif
501.LT. IF (IFLAG0) GOTO 300
502.GE. IF (KEEP(475)1) THEN
503 CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO,
504 & LD_BLOCFACTO, -6666,
505 & NB_BLR_L+1,
506 & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1,
507 & 2, 0, 0,
508 & .TRUE.)
509#if defined(BLR_MT)
510!$OMP BARRIER
511#endif
512.NE. IF (KEEP(486)2) THEN
513 CALL SMUMPS_DECOMPRESS_PANEL_I_NOOPT(
514 & A_PTR(POSELT), LA_PTR, 1_8,
515 & NCOL1, NCOL1,
516 & .TRUE.,
517 & NPIV1+1,
518 & 1,
519 & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'v', 1)
520 ENDIF
521 ENDIF
522 300 CONTINUE
523#if defined(BLR_MT)
524!$OMP END PARALLEL
525#endif
526.LT. IF (IFLAG0) GOTO 700
527 ENDIF
528 ENDIF
529.eq..AND. IF ( (KEEP(201)1)
530.OR..EQ. & (OOCWRITE_COMPATIBLE_WITH_BLR NPIV0) ) THEN
531 MonBloc%INODE = INODE
532 MonBloc%MASTER = .FALSE.
533 MonBloc%Typenode = 2
534 MonBloc%NROW = NROW1
535 MonBloc%NCOL = NCOL1
536 MonBloc%NFS = NASS1
537 MonBloc%LastPiv = NPIV1 + NPIV
538 MonBloc%LastPanelWritten_L = -9999
539 MonBloc%LastPanelWritten_U = -9999
540 NULLIFY(MonBloc%INDICES)
541 MonBloc%Last = LASTBL
542 STRAT = STRAT_TRY_WRITE
543 NextPivDummy = -8888
544 LIWFAC = IW(IOLDPS+XXI)
545 LAST_CALL = .FALSE.
546 CALL SMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L,
547 & A_PTR(POSELT),
548 & LA_PTR, MonBloc, NextPivDummy, NextPivDummy,
549 & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL)
550 ENDIF
551.GT. IF ( (NPIV 0)
552 & ) THEN
553 IF (LR_ACTIVATED) THEN
554.GT. IF (NELIM0) THEN
555 UPOS = 1_8+int(NPIV,8)
556 CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I(
557 & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS,
558 & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8,
559 & IFLAG, IERROR, LD_BLOCFACTO, NCOL1,
560 & BEGS_BLR_L(1), size(BEGS_BLR_L),
561 & CURRENT_BLR, BLR_L(1), NB_BLR_L+1,
562 & CURRENT_BLR+1, NELIM, 'n')
563 ENDIF
564#if defined(BLR_MT)
565!$OMP PARALLEL
566#endif
567 CALL SMUMPS_BLR_UPDATE_TRAILING_I(
568 & A_PTR(POSELT), LA_PTR, 1_8,
569 & IFLAG, IERROR, NCOL1,
570 & BEGS_BLR_L(1), size(BEGS_BLR_L),
571 & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR,
572 & BLR_L(1), NB_BLR_L+1,
573 & BLR_U(1), NB_BLR_U+1,
574 & 0,
575 & .TRUE.,
576 & NPIV1,
577 & 2, 0,
578 & KEEP(481), DKEEP(11), KEEP(466), KEEP(477)
579 & )
580#if defined(BLR_MT)
581!$OMP END PARALLEL
582#endif
583.LT. IF (IFLAG0) GOTO 700
584 ELSE
585 UPOS = POSBLOCFACTO+int(NPIV,8)
586 CALL sgemm('n','n', NCOL-NPIV, NROW1, NPIV,
587 & ALPHA,A(UPOS), NCOL,
588 & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1)
589 ENDIF
590 ENDIF
591 IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV
592 IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV
593 IF (LASTBL) THEN
594 IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) )
595 ENDIF
596.not..AND. IF ( LASTBL
597.EQ. & (IW(IOLDPS+1+KEEP(IXSZ)) IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN
598 write(*,*) 'internal error 1 **** in blacfacto '
599 CALL MUMPS_ABORT()
600 ENDIF
601 IF (LR_ACTIVATED) THEN
602.GT. IF ((NPIV0)
603 & ) THEN
604 CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8, KEEP(34))
605 DEALLOCATE(BLR_U)
606.EQ. IF (KEEP(486)3) THEN
607 CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8, KEEP(34))
608 DEALLOCATE(BLR_L)
609 ELSE
610 CALL UPD_MRY_LU_LRGAIN(BLR_L, NPARTSCB
611 & )
612 ENDIF
613 ENDIF
614 ENDIF
615 LRLU = LRLU + LA_BLOCFACTO
616 LRLUS = LRLUS + LA_BLOCFACTO
617 KEEP8(69) = KEEP8(69) - LA_BLOCFACTO
618 POSFAC = POSFAC - LA_BLOCFACTO
619 CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
620 & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS)
621 IWPOS = IWPOS - NPIV
622 FLOP1 = dble( NPIV1*NROW1 ) +
623 & dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1)
624 & -
625 & dble((NPIV1+NPIV)*NROW1 ) -
626 & dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1)
627 CALL SMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 )
628 IF (LASTBL) THEN
629.NE. IF (KEEP(486)0) THEN
630 IF (LR_ACTIVATED) THEN
631 CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1,
632 & KEEP(50), INODE)
633 ELSE
634 CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1,
635 & KEEP(50), INODE)
636 ENDIF
637 ENDIF
638 IF (LR_ACTIVATED) THEN
639 IF (COMPRESS_CB) THEN
640 CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF),
641 & BEGS_BLR_COL, NPARTSASS_MASTER_AUX)
642 BEGS_BLR_COL(1+NPARTSASS_MASTER) =
643 & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM
644 NB_BLR_COL = size(BEGS_BLR_COL) - 1
645.EQ. IF (NPIV0) THEN
646 call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L)
647 call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL)
648 IF (COMPRESS_CB) THEN
649 MAXI_CLUSTER=max(MAXI_CLUSTER_COL+NELIM,MAXI_CLUSTER_L)
650 ELSE
651 MAXI_CLUSTER=max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L)
652 ENDIF
653 LWORK = MAXI_CLUSTER*MAXI_CLUSTER
654 OMP_NUM = 1
655#if defined(BLR_MT)
656!$ OMP_NUM = OMP_GET_MAX_THREADS()
657#endif
658 ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER),
659 & RWORK(2*MAXI_CLUSTER*OMP_NUM),
660 & TAU(MAXI_CLUSTER*OMP_NUM),
661 & JPVT(MAXI_CLUSTER*OMP_NUM),
662 & WORK(LWORK*OMP_NUM), stat=allocok)
663 IF (allocok > 0 ) THEN
664 IFLAG = -13
665 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER
666 & + 2*MAXI_CLUSTER*OMP_NUM
667 & + MAXI_CLUSTER*OMP_NUM
668 & + MAXI_CLUSTER*OMP_NUM
669 & + LWORK*OMP_NUM
670 LP = ICNTL(1)
671.LE. IF (ICNTL(4) 0) LP=-1
672 IF (LP > 0) WRITE(LP,*) MYID,
673 & ': error allocation during smumps_process_blocfacto'
674 GOTO 700
675 ENDIF
676 ENDIF
677 allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER),
678 & stat=allocok)
679 IF (allocok > 0) THEN
680 IFLAG = -13
681 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER)
682 GOTO 700
683 ENDIF
684 CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB)
685 ENDIF
686#if defined(BLR_MT)
687!$OMP PARALLEL
688#endif
689 IF (COMPRESS_CB) THEN
690 CALL SMUMPS_COMPRESS_CB_I(
691 & A_PTR(POSELT), LA_PTR, 1_8, NCOL1,
692 & BEGS_BLR_L(1), size(BEGS_BLR_L),
693 & BEGS_BLR_COL(1), size(BEGS_BLR_COL),
694 & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER,
695 & NPARTSASS_MASTER,
696 & NROW1, NCOL1-NPIV1-NPIV, INODE,
697 & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR,
698 & DKEEP(12), KEEP(466), KEEP(484), KEEP(489),
699 & CB_LRB(1,1),
700 & WORK, TAU, JPVT, LWORK, RWORK, BLOCK,
701 & MAXI_CLUSTER, KEEP8, OMP_NUM,
702 & -9999, -9999, -9999, KEEP(1),
703 & IDUMMY, 0, -9999 )
704#if defined(BLR_MT)
705!$OMP BARRIER
706#endif
707 ENDIF
708#if defined(BLR_MT)
709!$OMP END PARALLEL
710#endif
711.LT. IF (IFLAG0) GOTO 700
712 ENDIF
713 CALL SMUMPS_END_FACTO_SLAVE(
714 & COMM_LOAD, ASS_IRECV,
715 & N, INODE, FPERE,
716 & root,
717 & MYID, COMM,
718 &
719 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
720 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA,
721 & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER,
722 & PAMASTER,
723 & NSTK_S, COMP, IFLAG, IERROR, PERM,
724 & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF,
725 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW,
726 & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
727 & LPTRAR, NELT, FRTPTR, FRTELT,
728 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
729 & , LRGROUPS
730 & )
731 ENDIF
732 IF (LR_ACTIVATED) THEN
733 IF (allocated(RWORK)) DEALLOCATE(RWORK)
734 IF (allocated(WORK)) DEALLOCATE(WORK)
735 IF (allocated(TAU)) DEALLOCATE(TAU)
736 IF (allocated(JPVT)) DEALLOCATE(JPVT)
737 IF (allocated(BLOCK)) DEALLOCATE(BLOCK)
738 IF (associated(BEGS_BLR_L)) THEN
739.NOT. IF ( KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L)
740 ENDIF
741.GT. IF ((NPIV0)
742 & ) THEN
743 IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U)
744 ENDIF
745 ENDIF
746 600 CONTINUE
747 RETURN
748 700 CONTINUE
749 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
750 RETURN
751 END SUBROUTINE SMUMPS_PROCESS_BLOCFACTO
752 SUBROUTINE SMUMPS_MPI_UNPACK_LR(
753 & BUFR, LBUFR, LBUFR_BYTES, POSITION,
754 & NPIV, NELIM, DIR,
755 & BLR_U, NB_BLOCK_U,
756 & BEGS_BLR_U, KEEP8,
757 & COMM, IERR, IFLAG, IERROR)
758 USE SMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB
759 USE SMUMPS_LR_TYPE
760 IMPLICIT NONE
761 INTEGER, INTENT(IN) :: LBUFR
762 INTEGER, INTENT(IN) :: LBUFR_BYTES
763 INTEGER, INTENT(IN) :: BUFR(LBUFR)
764 INTEGER, INTENT(INOUT) :: POSITION
765 INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV
766 CHARACTER(len=1) :: DIR
767 INTEGER, INTENT(IN) :: COMM
768 INTEGER, INTENT(INOUT) :: IFLAG, IERROR
769 INTEGER, INTENT(OUT) :: IERR
770 TYPE (LRB_TYPE), INTENT(OUT),
771 & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U
772 INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U
773 INTEGER(8) :: KEEP8(150)
774 LOGICAL :: ISLR
775 INTEGER :: ISLR_INT, I
776 INTEGER :: K, M, N
777 INCLUDE 'mpif.h'
778 INCLUDE 'mumps_tags.h'
779 IERR = 0
780.NE. IF (size(BLR_U)
781 & MAX(NB_BLOCK_U,1) ) THEN
782 WRITE(*,*) "Internal error 1 in SMUMPS_MPI_UNPACK",
783 & NB_BLOCK_U,size(BLR_U)
784 CALL MUMPS_ABORT()
785 ENDIF
786 BEGS_BLR_U(1) = 1
787 BEGS_BLR_U(2) = NPIV+NELIM+1
788 DO I = 1, NB_BLOCK_U
789 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
790 & ISLR_INT, 1, MPI_INTEGER, COMM, IERR )
791 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
792 & K, 1,
793 & MPI_INTEGER, COMM, IERR )
794 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
795 & M, 1,
796 & MPI_INTEGER, COMM, IERR )
797 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
798 & N, 1,
799 & MPI_INTEGER, COMM, IERR )
800 BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M
801.eq. IF (ISLR_INT 1) THEN
802 ISLR = .TRUE.
803 ELSE
804 ISLR = .FALSE.
805 ENDIF
806 CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR,
807 & IFLAG, IERROR, KEEP8 )
808.LT. IF (IFLAG0) RETURN
809 IF (ISLR) THEN
810.GT. IF (K 0) THEN
811 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
812 & BLR_U(I)%Q(1,1), M*K, MPI_REAL,
813 & COMM, IERR )
814 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
815 & BLR_U(I)%R(1,1), N*K, MPI_REAL,
816 & COMM, IERR)
817 ENDIF
818 ELSE
819 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
820 & BLR_U(I)%Q(1,1), M*N, MPI_REAL,
821 & COMM, IERR)
822 ENDIF
823 ENDDO
824 RETURN
825 END SUBROUTINE SMUMPS_MPI_UNPACK_LR
max
#define max(a, b)
Definition macros.h:21
mumps_ooc_common
Definition mumps_ooc_common.F:14
mumps_ooc_common::strat_try_write
integer, public strat_try_write
Definition mumps_ooc_common.F:45
mumps_ooc_common::typef_l
integer, public typef_l
Definition mumps_ooc_common.F:18
smumps_ana_lr
Definition sana_lr.F:14
smumps_ana_lr::get_cut
subroutine get_cut(iwr, nass, ncb, lrgroups, npartscb, npartsass, cut)
Definition sana_lr.F:25
smumps_dynamic_memory_m
Definition sfac_mem_dynamic.F:14
smumps_dynamic_memory_m::smumps_dm_set_dynptr
subroutine smumps_dm_set_dynptr(cb_state, a, la, pamaster_or_ptrast, ixxd, ixxr, son_a, iachk, recsize)
Definition sfac_mem_dynamic.F:19
smumps_fac_lr
Definition sfac_lr.F:14
smumps_load
Definition smumps_load.F:14
smumps_load::myid
integer, save, private myid
Definition smumps_load.F:57
smumps_lr_core
Definition slr_core.F:18
smumps_lr_data_m
Definition smumps_lr_data_m.F:14
smumps_lr_stats
Definition slr_stats.F:14
smumps_lr_type
Definition slr_type.F:14
smumps_ooc
Definition smumps_ooc.F:14
smumps_struc_def
Definition smumps_struc_def.F:14
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102
smumps_process_blocfacto
recursive subroutine smumps_process_blocfacto(comm_load, ass_irecv, bufr, lbufr, lbufr_bytes, procnode_steps, msgsou, slavef, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptrast, nstk_s, perm, comp, step, pimaster, pamaster, posfac, myid, comm, iflag, ierror, nbfin ptlust_s, ptrfac, root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, ipool, lpool, leaf, nd, frere_steps, lptrar, nelt, frtptr, frtelt, istep_to_iniv2, tab_pos_in_pere, lrgroups)
Definition sfac_process_blocfacto.F:32