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

Go to the source code of this file.

Functions/Subroutines

subroutine smumps_process_root2slave (tot_root_size, tot_cont_to_recv, root, bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptlust, ptrfac, ptrast, step, pimaster, pamaster, nstk_s, comp, iflag, ierror, comm, comm_load, ipool, lpool, leaf, nbfin, myid, slavef opassw, opeliw, itloc, rhs_mumps, fils, dad, lptrar, nelt, frtptr, frtelt, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, nd)
subroutine smumps_copy_root (new, m_new, n_new, old, m_old, n_old)

Function/Subroutine Documentation

◆ smumps_copy_root()

subroutine smumps_copy_root ( real, dimension( m_new, n_new ) new,
integer m_new,
integer n_new,
real, dimension( m_old, n_old ) old,
integer m_old,
integer n_old )

Definition at line 331 of file sfac_process_root2slave.F.

333 INTEGER M_NEW, N_NEW, M_OLD, N_OLD
334 REAL NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD )
335 INTEGER J
336 REAL ZERO
337 parameter( zero = 0.0e0 )
338 DO j = 1, n_old
339 new( 1: m_old, j ) = old( 1: m_old, j )
340 new( m_old + 1: m_new, j ) = zero
341 END DO
342 new( 1: m_new,n_old + 1: n_new ) = zero
343 RETURN

◆ smumps_process_root2slave()

subroutine smumps_process_root2slave ( integer tot_root_size,
integer tot_cont_to_recv,
type (smumps_root_struc) root,
integer, dimension( lbufr ) bufr,
integer lbufr,
integer lbufr_bytes,
integer, dimension( keep(28) ) procnode_steps,
integer(8) posfac,
integer iwpos,
integer iwposcb,
integer(8) iptrlu,
integer(8) lrlu,
integer(8) lrlus,
integer n,
integer, dimension( liw ) iw,
integer liw,
real, dimension( la ) a,
integer(8) la,
integer, dimension(keep(28)) ptrist,
integer, dimension(keep(28)) ptlust,
integer(8), dimension(keep(28)) ptrfac,
integer(8), dimension(keep(28)) ptrast,
integer, dimension(n) step,
integer, dimension(keep(28)) pimaster,
integer(8), dimension(keep(28)) pamaster,
integer, dimension( keep(28) ) nstk_s,
integer comp,
integer iflag,
integer ierror,
integer comm,
integer comm_load,
integer, dimension( lpool ) ipool,
integer lpool,
integer leaf,
integer nbfin,
integer myid,
integer slavef,
double precision opassw,
double precision opeliw,
integer, dimension(n+keep(253)) itloc,
real, dimension(keep(255)) rhs_mumps,
integer, dimension(n) fils,
integer, dimension(keep(28)) dad,
integer lptrar,
integer nelt,
integer, dimension( n+1 ) frtptr,
integer, dimension( nelt ) frtelt,
integer(8), dimension(lptrar), intent(in) ptrarw,
integer(8), dimension(lptrar), intent(in) ptraiw,
integer, dimension(keep8(27)) intarr,
real, dimension(keep8(26)) dblarr,
integer, dimension(60) icntl,
integer, dimension(500) keep,
integer(8), dimension(150) keep8,
real, dimension(230) dkeep,
integer, dimension( keep(28) ) nd )

Definition at line 14 of file sfac_process_root2slave.F.

30 USE smumps_load
31 USE smumps_ooc
32 USE smumps_struc_def, ONLY : smumps_root_struc
33 IMPLICIT NONE
34 include 'mpif.h'
35 TYPE (smumps_root_struc) :: root
36 INTEGER KEEP(500), ICNTL(60)
37 INTEGER(8) KEEP8(150)
38 REAL DKEEP(230)
39 INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV
40 INTEGER LBUFR, LBUFR_BYTES
41 INTEGER BUFR( LBUFR )
42 INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC
43 INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28))
44 INTEGER(8) :: PAMASTER(KEEP(28))
45 INTEGER IWPOS, IWPOSCB
46 INTEGER N, LIW
47 INTEGER IW( LIW )
48 REAL A( LA )
49 INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28))
50 INTEGER STEP(N), PIMASTER(KEEP(28))
51 INTEGER COMP
52 INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) )
53 INTEGER ND( KEEP(28) )
54 INTEGER IFLAG, IERROR, COMM, COMM_LOAD
55 INTEGER LPOOL, LEAF
56 INTEGER IPOOL( LPOOL )
57 INTEGER MYID, SLAVEF, NBFIN
58 DOUBLE PRECISION OPASSW, OPELIW
59 INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28))
60 INTEGER LPTRAR, NELT
61 INTEGER FRTPTR( N+1 ), FRTELT( NELT )
62 INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR)
63 REAL :: RHS_MUMPS(KEEP(255))
64 INTEGER INTARR(KEEP8(27))
65 REAL DBLARR(KEEP8(26))
66 INTEGER :: allocok
67 REAL, DIMENSION(:,:), POINTER :: TMP
68 INTEGER NEW_LOCAL_M, NEW_LOCAL_N
69 INTEGER OLD_LOCAL_M, OLD_LOCAL_N
70 INTEGER I, J
71 INTEGER LREQI, IROOT
72 INTEGER(8) :: LREQA
73 INTEGER POSHEAD, IPOS_SON,IERR
74 LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT
75 REAL ZERO
76 parameter( zero = 0.0e0 )
77 include 'mumps_headers.h'
78 INTEGER numroc, MUMPS_PROCNODE
79 EXTERNAL numroc, mumps_procnode
80 iroot = keep( 38 )
81 root%TOT_ROOT_SIZE = tot_root_size
82 master_of_root = ( myid .EQ.
83 & mumps_procnode( procnode_steps(step(iroot)),
84 & keep(199) ) )
85 new_local_m = numroc( tot_root_size, root%MBLOCK,
86 & root%MYROW, 0, root%NPROW )
87 new_local_m = max( 1, new_local_m )
88 new_local_n = numroc( tot_root_size, root%NBLOCK,
89 & root%MYCOL, 0, root%NPCOL )
90 IF ( ptrist(step( iroot )).GT.0) THEN
91 old_local_n = -iw( ptrist(step( iroot )) + keep(ixsz) )
92 old_local_m = iw( ptrist(step( iroot )) + 1 + keep(ixsz))
93 ELSE
94 old_local_n = 0
95 old_local_m = new_local_m
96 ENDIF
97 IF (ptrist(step(iroot)) .EQ.0) THEN
98 no_old_root = .true.
99 ELSE
100 no_old_root =.false.
101 ENDIF
102 IF (keep(60) .NE. 0) THEN
103 IF ( master_of_root ) THEN
104 lreqi=6+2*tot_root_size+keep(ixsz)
105 lreqa=0_8
106 IF ( iwpos + lreqi - 1. gt. iwposcb ) THEN
107 CALL smumps_compre_new( n, keep, iw, liw, a, la,
108 & lrlu, iptrlu,
109 & iwpos, iwposcb, ptrist, ptrast,
110 & step, pimaster, pamaster, lrlus,
111 & keep(ixsz),comp,dkeep(97),
112 & myid, slavef, procnode_steps, dad )
113 IF ( lrlu .NE. lrlus ) THEN
114 WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=',
115 & lrlu, lrlus
116 iflag = -9
117 CALL mumps_set_ierror(lreqa-lrlus, ierror)
118 GOTO 700
119 END IF
120 ENDIF
121 IF ( iwpos + lreqi - 1. gt. iwposcb ) THEN
122 iflag = -8
123 ierror = iwpos + lreqi - 1 - iwposcb
124 GOTO 700
125 ENDIF
126 ptlust(step(iroot))= iwpos
127 iwpos = iwpos + lreqi
128 poshead = ptlust( step(iroot))
129 iw( poshead + xxi )=lreqi
130 CALL mumps_storei8( lreqa, iw(poshead + xxr) )
131 CALL mumps_storei8( 0_8, iw(poshead + xxd) )
132 iw( poshead + xxs )=-9999
133 iw(poshead+xxs+1:poshead+keep(ixsz)-1)=-99999
134 iw( poshead +keep(ixsz)) = 0
135 iw( poshead + 1 +keep(ixsz)) = -1
136 iw( poshead + 2 +keep(ixsz)) = -1
137 iw( poshead + 4 +keep(ixsz)) = step(iroot)
138 iw( poshead + 5 +keep(ixsz)) = 0
139 iw( poshead + 3 +keep(ixsz)) = tot_root_size
140 ELSE
141 ptlust(step(iroot)) = -4444
142 ENDIF
143 ptrist(step(iroot)) = 0
144 ptrfac(step(iroot)) = -4445_8
145 IF (root%yes .and. no_old_root) THEN
146 IF (new_local_n .GT. 0) THEN
147 CALL smumps_set_to_zero(root%SCHUR_POINTER(1),
148 & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC,
149 & keep)
150 IF (keep(55).EQ.0) THEN
151 CALL smumps_asm_arr_root( n, root, iroot,
152 & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC,
153 & root%SCHUR_NLOC, fils, ptraiw, ptrarw, intarr, dblarr,
154 & keep8(27), keep8(26), myid )
155 ELSE
156 CALL smumps_asm_elt_root(n, root,
157 & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC,
158 & root%SCHUR_NLOC, lptrar, nelt, frtptr, frtelt,
159 & ptraiw, ptrarw, intarr, dblarr,
160 & keep8(27), keep8(26), keep, keep8, myid )
161 ENDIF
162 ENDIF
163 ENDIF
164 ELSE
165 IF ( master_of_root ) THEN
166 lreqi = 6 + 2 * tot_root_size+keep(ixsz)
167 ELSE
168 lreqi = 6+keep(ixsz)
169 END IF
170 lreqa = int(new_local_m, 8) * int(new_local_n, 8)
171 CALL smumps_get_size_needed(
172 & lreqi , lreqa, .false.,
173 & keep(1), keep8(1),
174 & n, iw, liw, a, la,
175 & lrlu, iptrlu,
176 & iwpos, iwposcb, ptrist, ptrast,
177 & step, pimaster, pamaster, lrlus,
178 & keep(ixsz), comp, dkeep(97),
179 & myid, slavef, procnode_steps, dad,
180 & iflag, ierror )
181 IF (iflag.LT.0) GOTO 700
182 ptlust(step( iroot )) = iwpos
183 iwpos = iwpos + lreqi
184 IF (lreqa.EQ.0_8) THEN
185 ptrast(step(iroot)) = posfac
186 ptrfac(step(iroot)) = posfac
187 ELSE
188 ptrast(step(iroot)) = posfac
189 ptrfac(step(iroot)) = posfac
190 ENDIF
191 posfac = posfac + lreqa
192 lrlu = lrlu - lreqa
193 lrlus = lrlus - lreqa
194 keep8(67) = min(keep8(67), lrlus)
195 keep8(69) = keep8(69) + lreqa
196 keep8(68) = max(keep8(69), keep8(68))
197 CALL smumps_load_mem_update(.false.,.false.,
198 & la-lrlus,0_8,lreqa,keep,keep8,lrlus)
199 poshead = ptlust( step(iroot))
200 iw( poshead + xxi ) = lreqi
201 CALL mumps_storei8( lreqa, iw(poshead + xxr))
202 CALL mumps_storei8( 0_8, iw(poshead + xxd))
203 iw( poshead + xxs ) = s_notfree
204 iw(poshead+xxs+1:poshead+keep(ixsz)-1)=-99999
205 iw( poshead + keep(ixsz) ) = 0
206 iw( poshead + 1 + keep(ixsz) ) = new_local_n
207 iw( poshead + 2 + keep(ixsz) ) = new_local_m
208 iw( poshead + 4 + keep(ixsz) ) = step(iroot)
209 iw( poshead + 5 + keep(ixsz) ) = 0
210 IF ( master_of_root ) THEN
211 iw( poshead + 3 + keep(ixsz) ) = tot_root_size
212 ELSE
213 iw( poshead + 3 + keep(ixsz) ) = 0
214 ENDIF
215 IF ( ptrist(step(iroot)) .EQ. 0) THEN
216 CALL smumps_set_to_zero(a(ptrast(step(iroot))),
217 & new_local_m, new_local_m, new_local_n, keep)
218 IF (keep(55) .EQ.0 ) THEN
219 CALL smumps_asm_arr_root( n, root, iroot,
220 & a(ptrast(step(iroot))),
221 & new_local_m, new_local_m, new_local_n,
222 & fils, ptraiw, ptrarw, intarr, dblarr,
223 & keep8(27), keep8(26), myid )
224 ELSE
225 CALL smumps_asm_elt_root( n, root,
226 & a(ptrast(step(iroot))),
227 & new_local_m, new_local_m, new_local_n,
228 & lptrar, nelt, frtptr, frtelt,
229 & ptraiw, ptrarw, intarr, dblarr,
230 & keep8(27), keep8(26), keep, keep8, myid )
231 ENDIF
232 pamaster(step(iroot)) = 0_8
233 ELSE IF ( ptrist(step(iroot)) .LT. 0 ) THEN
234 CALL smumps_set_to_zero(a(ptrast(step(iroot))),
235 & new_local_m, new_local_m, new_local_n, keep)
236 ELSE
237 old_local_n = -iw( ptrist(step( iroot )) + keep(ixsz) )
238 old_local_m = iw( ptrist(step( iroot )) + 1 + keep(ixsz))
239 IF ( tot_root_size .eq. root%ROOT_SIZE ) THEN
240 IF ( lreqa .NE. int(old_local_m,8) * int(old_local_n,8) )
241 & THEN
242 write(*,*) 'error 1 in PROCESS_ROOT2SLAVE',
243 & old_local_m, old_local_n
244 CALL mumps_abort()
245 END IF
246 CALL smumps_copyi8size(lreqa,
247 & a( pamaster(step(iroot)) ),
248 & a( ptrast (step(iroot)) ) )
249 ELSE
250 CALL smumps_copy_root( a( ptrast(step(iroot))),
251 & new_local_m,
252 & new_local_n, a( pamaster( step(iroot)) ), old_local_m,
253 & old_local_n )
254 END IF
255 IF ( ptrist( step( iroot ) ) .GT. 0 ) THEN
256 ipos_son= ptrist( step(iroot))
257 CALL smumps_free_block_cb_static(.false.,
258 & myid, n, ipos_son,
259 & iw, liw, lrlu, lrlus, iptrlu,
260 & iwposcb, la, keep,keep8, .false.
261 & )
262 END IF
263 ENDIF
264 ptrist(step( iroot )) = 0
265 pamaster(step( iroot )) = 0_8
266 ENDIF
267 IF ( no_old_root ) THEN
268 IF (keep(253) .GT.0) THEN
269 root%RHS_NLOC = numroc( keep(253), root%NBLOCK,
270 & root%MYCOL, 0, root%NPCOL )
271 root%RHS_NLOC = max( root%RHS_NLOC, 1 )
272 ELSE
273 root%RHS_NLOC = 1
274 ENDIF
275 IF (associated(root%RHS_ROOT)) DEALLOCATE(root%RHS_ROOT)
276 ALLOCATE(root%RHS_ROOT(new_local_m, root%RHS_NLOC),
277 & stat=allocok)
278 IF ( allocok.GT.0 ) THEN
279 iflag = -13
280 ierror = new_local_n * root%RHS_NLOC
281 GOTO 700
282 ENDIF
283 IF (keep(253) .NE. 0) THEN
284 root%RHS_ROOT=zero
285 CALL smumps_asm_rhs_root( n, fils, root, keep, rhs_mumps,
286 & iflag, ierror )
287 ENDIF
288 ELSE IF (new_local_m.GT.old_local_m .AND. keep(253) .GT.0) THEN
289 tmp => root%RHS_ROOT
290 NULLIFY(root%RHS_ROOT)
291 ALLOCATE (root%RHS_ROOT(new_local_m, root%RHS_NLOC),
292 & stat=allocok)
293 IF ( allocok.GT.0) THEN
294 iflag=-13
295 ierror = new_local_m*root%RHS_NLOC
296 GOTO 700
297 ENDIF
298 DO j = 1, root%RHS_NLOC
299 DO i = 1, old_local_m
300 root%RHS_ROOT(i,j)=tmp(i,j)
301 ENDDO
302 DO i = old_local_m+1, new_local_m
303 root%RHS_ROOT(i,j) = zero
304 ENDDO
305 ENDDO
306 DEALLOCATE(tmp)
307 NULLIFY(tmp)
308 ENDIF
309 keep(121) = keep(121) + tot_cont_to_recv
310 IF ( keep(121) .eq. 0 ) THEN
311 IF (keep(201).EQ.1) THEN
312 CALL smumps_ooc_force_wrt_buf_panel(ierr)
313 ELSE IF (keep(201).EQ.2) THEN
314 CALL smumps_force_write_buf(ierr)
315 ENDIF
316 CALL smumps_insert_pool_n( n, ipool, lpool, procnode_steps,
317 & slavef, keep(199), keep(28), keep(76), keep(80), keep(47),
318 & step, iroot + n )
319 IF (keep(47) .GE. 3) THEN
320 CALL smumps_load_pool_upd_new_pool(
321 & ipool, lpool,
322 & procnode_steps, keep,keep8, slavef, comm_load,
323 & myid, step, n, nd, fils )
324 ENDIF
325 END IF
326 RETURN
327 700 CONTINUE
328 CALL smumps_bdc_error( myid, slavef, comm, keep )
329 RETURN
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
smumps_load
Definition smumps_load.F:14
smumps_load::smumps_load_mem_update
subroutine, public smumps_load_mem_update(ssarbr, process_bande_arg, mem_value, new_lu, inc_mem_arg, keep, keep8, lrlus)
Definition smumps_load.F:920
smumps_load::smumps_load_pool_upd_new_pool
subroutine, public smumps_load_pool_upd_new_pool(pool, lpool, procnode, keep, keep8, slavef, comm, myid, step, n, nd, fils)
Definition smumps_load.F:1820
smumps_ooc
Definition smumps_ooc.F:14
smumps_ooc::smumps_ooc_force_wrt_buf_panel
subroutine smumps_ooc_force_wrt_buf_panel(ierr)
Definition smumps_ooc.F:2965
smumps_ooc::smumps_force_write_buf
subroutine smumps_force_write_buf(ierr)
Definition smumps_ooc.F:2951
smumps_struc_def
Definition smumps_struc_def.F:14
smumps_set_to_zero
subroutine smumps_set_to_zero(a, lld, m, n, keep)
Definition sarrowheads.F:916
smumps_bdc_error
subroutine smumps_bdc_error(myid, slavef, comm, keep)
Definition sbcast_int.F:38
smumps_get_size_needed
subroutine smumps_get_size_needed(sizei_needed, sizer_needed, skip_top_stack, keep, keep8, n, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad, iflag, ierror)
Definition sfac_mem_compress_cb.F:437
smumps_compre_new
subroutine smumps_compre_new(n, keep, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad)
Definition sfac_mem_compress_cb.F:120
smumps_free_block_cb_static
subroutine smumps_free_block_cb_static(ssarbr, myid, n, iposblock, iw, liw, lrlu, lrlus, iptrlu, iwposcb, la, keep, keep8, in_place_stats)
Definition sfac_mem_free_block_cb.F:20
smumps_copy_root
subroutine smumps_copy_root(new, m_new, n_new, old, m_old, n_old)
Definition sfac_process_root2slave.F:333
smumps_insert_pool_n
subroutine smumps_insert_pool_n(n, pool, lpool, procnode, slavef, keep199, k28, k76, k80, k47, step, inode)
Definition sfac_sol_pool.F:27
smumps_copyi8size
subroutine smumps_copyi8size(n8, src, dest)
Definition stools.F:1823
smumps_asm_elt_root
subroutine smumps_asm_elt_root(n, root, valroot, local_m_lld, local_m, local_n, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, keep, keep8, myid)
Definition stype3_root.F:1222
smumps_asm_arr_root
subroutine smumps_asm_arr_root(n, root, iroot, valroot, local_m_lld, local_m, local_n, fils, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, myid)
Definition stype3_root.F:1335
smumps_asm_rhs_root
subroutine smumps_asm_rhs_root(n, fils, root, keep, rhs_mumps, iflag, ierror)
Definition stype3_root.F:1298
mumps_storei8
subroutine mumps_storei8(i8, int_array)
Definition tools_common.F:871
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865