OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zfac_process_contrib_type3.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 zmumps_process_contrib_type3(BUFR,LBUFR,
15 & LBUFR_BYTES,
16 & root, N, IW, LIW, A, LA,
17 & LRLU, IPTRLU, IWPOS, IWPOSCB,
18 & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER,
19 & COMP, LRLUS, IPOOL, LPOOL, LEAF,
20 & FILS, DAD, MYID,
21 & LPTRAR, NELT, FRTPTR, FRTELT,
22 & PTRAIW, PTRARW, INTARR, DBLARR,
23 & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD,
24 & ITLOC, RHS_MUMPS,
25 & ND,PROCNODE_STEPS, SLAVEF, OPASSW )
26 USE zmumps_load
27 USE zmumps_ooc
28 USE zmumps_struc_def, ONLY : zmumps_root_struc
29 IMPLICIT NONE
30 TYPE (ZMUMPS_ROOT_STRUC ) :: root
31 INTEGER :: KEEP( 500 )
32 INTEGER(8) :: KEEP8(150)
33 DOUBLE PRECISION :: DKEEP(230)
34 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS
35 INTEGER(8) :: PAMASTER(KEEP(28))
36 INTEGER(8) :: PTRAST(KEEP(28))
37 INTEGER(8) :: PTRFAC(KEEP(28))
38 INTEGER LBUFR, LBUFR_BYTES, N, LIW,
39 & iwpos, iwposcb, comp, comm, comm_load, iflag,
40 & ierror
41 INTEGER LPOOL, LEAF
42 INTEGER IPOOL( LEAF )
43 INTEGER PTRIST(KEEP(28))
44 INTEGER PTLUST(KEEP(28))
45 INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) )
46 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
47 INTEGER BUFR( LBUFR_BYTES )
48 INTEGER IW( LIW )
49 INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28))
50 INTEGER SLAVEF
51 COMPLEX(kind=8) A( LA )
52 INTEGER MYID
53 INTEGER FILS( N ), DAD(KEEP(28))
54 INTEGER LPTRAR, NELT
55 INTEGER FRTPTR( N+1 ), FRTELT( NELT )
56 INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR )
57 INTEGER INTARR(KEEP8(27))
58 COMPLEX(kind=8) DBLARR(KEEP8(26))
59 DOUBLE PRECISION OPASSW
60 include 'mpif.h'
61 INTEGER IERR
62 EXTERNAL mumps_procnode
63 INTEGER MUMPS_PROCNODE
64 INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI
65 INTEGER(8) :: LREQA, POS_ROOT
66 INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF
67 INTEGER NSUPCOL_EFF
68 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
69 INTEGER NSUPROW, NSUPCOL, BBPCBP
70 include 'mumps_headers.h'
71 position = 0
72 CALL mpi_unpack( bufr, lbufr_bytes, position,
73 & ison, 1, mpi_integer, comm, ierr )
74 CALL mpi_unpack( bufr, lbufr_bytes, position,
75 & nsubset_row, 1, mpi_integer, comm, ierr )
76 CALL mpi_unpack( bufr, lbufr_bytes, position,
77 & nsuprow, 1, mpi_integer, comm, ierr )
78 CALL mpi_unpack( bufr, lbufr_bytes, position,
79 & nsubset_col, 1, mpi_integer, comm, ierr )
80 CALL mpi_unpack( bufr, lbufr_bytes, position,
81 & nsupcol, 1, mpi_integer, comm, ierr )
82 CALL mpi_unpack( bufr, lbufr_bytes, position,
83 & nbrows_already_sent, 1, mpi_integer,
84 & comm, ierr )
85 CALL mpi_unpack( bufr, lbufr_bytes, position,
86 & nbrows_packet, 1, mpi_integer,
87 & comm, ierr )
88 CALL mpi_unpack( bufr, lbufr_bytes, position,
89 & bbpcbp, 1, mpi_integer,
90 & comm, ierr )
91 IF (bbpcbp .EQ. 1) THEN
92 nsubset_col_eff = nsubset_col - nsupcol
93 nsupcol_eff = 0
94 ELSE
95 nsubset_col_eff = nsubset_col
96 nsupcol_eff = nsupcol
97 ENDIF
98 iroot = keep( 38 )
99 IF ( ptrist( step(iroot) ) .NE. 0 .OR.
100 & ptlust( step(iroot)) .NE. 0 ) THEN
101 IF (nbrows_already_sent + nbrows_packet .EQ. nsubset_row
102 & - nsuprow .OR. nsubset_row - nsuprow.EQ.0 .OR.
103 & nsubset_col_eff .EQ. 0)THEN
104 keep(121) = keep(121) - 1
105 IF ( keep(121) .eq. 0 ) THEN
106 IF (keep(201).EQ.1) THEN
107 CALL zmumps_ooc_force_wrt_buf_panel(ierr)
108 ELSEIF (keep(201).EQ.2) THEN
109 CALL zmumps_force_write_buf(ierr)
110 ENDIF
111 CALL zmumps_insert_pool_n( n, ipool, lpool,
112 & procnode_steps, slavef, keep(199),
113 & keep(28), keep(76),
114 & keep(80), keep(47),
115 & step, iroot + n)
116 IF (keep(47) .GE. 3) THEN
117 CALL zmumps_load_pool_upd_new_pool(
118 & ipool, lpool,
119 & procnode_steps, keep,keep8, slavef, comm_load,
120 & myid, step, n, nd, fils )
121 ENDIF
122 ENDIF
123 ENDIF
124 ELSE
125 IF (nbrows_already_sent + nbrows_packet .EQ.
126 & nsubset_row - nsuprow .OR.
127 & nsubset_row - nsuprow.EQ.0 .OR.
128 & nsubset_col_eff .EQ. 0)THEN
129 keep(121)=-1
130 ENDIF
131 CALL zmumps_root_alloc_static( root, iroot, n,
132 & iw, liw, a, la,
133 & fils, dad, myid, slavef, procnode_steps,
134 & lptrar, nelt, frtptr, frtelt,
135 & ptraiw, ptrarw, intarr, dblarr,
136 & lrlu, iptrlu,
137 & iwpos, iwposcb, ptrist, ptrast,
138 & step, pimaster, pamaster, itloc, rhs_mumps,
139 & comp, lrlus, iflag, keep,keep8,dkeep,ierror )
140 IF ( iflag .LT. 0 ) RETURN
141 END IF
142 IF (keep(60) .EQ.0) THEN
143 IF ( ptrist(step(iroot)) .GE. 0 ) THEN
144 IF ( ptrist(step(iroot)) .NE. 0 ) THEN
145 local_n = -iw( ptrist(step( iroot )) + keep(ixsz) )
146 local_m = iw( ptrist(step( iroot )) + 1 + keep(ixsz))
147 pos_root = pamaster(step( iroot ))
148 ELSE
149 local_n = iw( ptlust(step( iroot ) ) + 1 + keep(ixsz))
150 local_m = iw( ptlust(step( iroot ) ) + 2 + keep(ixsz))
151 pos_root = ptrfac(iw(ptlust(step(iroot))+4+
152 & keep(ixsz)))
153 END IF
154 ENDIF
155 ELSE
156 local_m = root%SCHUR_LLD
157 local_n = root%SCHUR_NLOC
158 ENDIF
159 IF ( (bbpcbp.EQ.1).AND. (nbrows_already_sent.EQ.0).AND.
160 & (min(nsuprow, nsupcol) .GT. 0)
161 & ) THEN
162 lreqi = nsuprow+nsupcol
163 lreqa = int(nsuprow,8) * int(nsupcol,8)
164 IF ( (lreqa.NE.0_8) .AND.
165 & (ptrist(step(iroot)).LT.0).AND.
166 & keep(60)==0) THEN
167 WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3'
168 CALL mumps_abort()
169 ENDIF
170 CALL zmumps_alloc_cb(.false.,0_8,.false.,.false.,
171 & myid,n,keep,keep8,dkeep,iw,liw,a, la,
172 & lrlu, iptrlu, iwpos, iwposcb, slavef, procnode_steps, dad,
173 & ptrist, ptrast, step, pimaster, pamaster,
174 & lreqi, lreqa, -1234, s_notfree, .false.,
175 & comp, lrlus, keep8(67), iflag, ierror
176 & )
177 IF ( iflag .LT. 0 ) RETURN
178 CALL mpi_unpack( bufr, lbufr_bytes, position,
179 & iw( iwposcb + 1 ), lreqi,
180 & mpi_integer, comm, ierr )
181 CALL mpi_unpack( bufr, lbufr_bytes, position,
182 & a( iptrlu + 1_8 ), int(lreqa),
183 & mpi_double_complex, comm, ierr )
184 opassw = opassw + lreqa
185 CALL zmumps_ass_root( root, keep(50), nsuprow, nsupcol,
186 & iw( iwposcb + 1 ),
187 & iw( iwposcb + nsuprow + 1 ), nsupcol,
188 & a( iptrlu + 1_8 ),
189 & a( 1 ),
190 & local_m, local_n,
191 & root%RHS_ROOT(1,1), root%RHS_NLOC,
192 & 1)
193 iwposcb = iwposcb + lreqi
194 iptrlu = iptrlu + lreqa
195 lrlu = lrlu + lreqa
196 lrlus = lrlus + lreqa
197 keep8(69) = keep8(69) - lreqa
198 CALL zmumps_load_mem_update(.false.,.false.,
199 & la-lrlus,0_8,-lreqa,keep,keep8,lrlus)
200 ENDIF
201 lreqi = nbrows_packet + nsubset_col_eff
202 lreqa = int(nbrows_packet,8) * int(nsubset_col_eff,8)
203 IF ( (lreqa.NE.0_8) .AND.
204 & (ptrist(step(iroot)).LT.0).AND.
205 & keep(60)==0) THEN
206 WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3'
207 CALL mumps_abort()
208 ENDIF
209 IF (lreqa.NE.0_8) THEN
210 CALL zmumps_alloc_cb(.false.,0_8,.false.,.false.,
211 & myid,n,keep,keep8,dkeep,iw,liw,a, la,
212 & lrlu, iptrlu, iwpos, iwposcb, slavef, procnode_steps, dad,
213 & ptrist, ptrast, step, pimaster, pamaster,
214 & lreqi, lreqa, -1234, s_notfree, .false.,
215 & comp, lrlus, keep8(67), iflag, ierror
216 & )
217 IF ( iflag .LT. 0 ) RETURN
218 CALL mpi_unpack( bufr, lbufr_bytes, position,
219 & iw( iwposcb + 1 ), lreqi,
220 & mpi_integer, comm, ierr )
221 CALL mpi_unpack( bufr, lbufr_bytes, position,
222 & a( iptrlu + 1_8 ), int(lreqa),
223 & mpi_double_complex, comm, ierr )
224 opassw = opassw + lreqa
225 IF (keep(60).EQ.0) THEN
226 CALL zmumps_ass_root( root, keep(50),
227 & nbrows_packet, nsubset_col_eff,
228 & iw( iwposcb + 1 ),
229 & iw( iwposcb + nbrows_packet + 1 ),
230 & nsupcol_eff,
231 & a( iptrlu + 1_8 ),
232 & a( pos_root ), local_m, local_n,
233 & root%RHS_ROOT(1,1), root%RHS_NLOC,
234 & 0)
235 ELSE
236 CALL zmumps_ass_root( root, keep(50),
237 & nbrows_packet, nsubset_col_eff,
238 & iw( iwposcb + 1 ),
239 & iw( iwposcb + nbrows_packet + 1 ),
240 & nsupcol_eff,
241 & a( iptrlu + 1_8 ),
242 & root%SCHUR_POINTER(1),
243 & root%SCHUR_LLD , root%SCHUR_NLOC,
244 & root%RHS_ROOT(1,1), root%RHS_NLOC,
245 & 0)
246 ENDIF
247 iwposcb = iwposcb + lreqi
248 iptrlu = iptrlu + lreqa
249 lrlu = lrlu + lreqa
250 lrlus = lrlus + lreqa
251 keep8(69) = keep8(69) - lreqa
252 CALL zmumps_load_mem_update(.false.,.false.,
253 & la-lrlus,0_8,-lreqa,keep,keep8,lrlus)
254 ENDIF
255 RETURN
256 END SUBROUTINE zmumps_process_contrib_type3
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
min
#define min(a, b)
Definition macros.h:20
mpi_unpack
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
zmumps_load
Definition zmumps_load.F:14
zmumps_load::zmumps_load_pool_upd_new_pool
subroutine, public zmumps_load_pool_upd_new_pool(pool, lpool, procnode, keep, keep8, slavef, comm, myid, step, n, nd, fils)
Definition zmumps_load.F:1820
zmumps_load::zmumps_load_mem_update
subroutine, public zmumps_load_mem_update(ssarbr, process_bande_arg, mem_value, new_lu, inc_mem_arg, keep, keep8, lrlus)
Definition zmumps_load.F:920
zmumps_ooc
Definition zmumps_ooc.F:14
zmumps_ooc::zmumps_ooc_force_wrt_buf_panel
subroutine zmumps_ooc_force_wrt_buf_panel(ierr)
Definition zmumps_ooc.F:2965
zmumps_ooc::zmumps_force_write_buf
subroutine zmumps_force_write_buf(ierr)
Definition zmumps_ooc.F:2951
zmumps_struc_def
Definition zmumps_struc_def.F:14
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
zmumps_alloc_cb
subroutine zmumps_alloc_cb(inplace, min_space_in_place, ssarbr, process_bande, myid, n, keep, keep8, dkeep, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, slavef, procnode_steps, dad, ptrist, ptrast, step, pimaster, pamaster, lreq, lreqcb, node_arg, state_arg, set_header, comp, lrlus, lrlusm, iflag, ierror)
Definition zfac_mem_alloc_cb.F:23
zmumps_process_contrib_type3
subroutine zmumps_process_contrib_type3(bufr, lbufr, lbufr_bytes, root, n, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptlust, ptrfac, ptrast, step, pimaster, pamaster, comp, lrlus, ipool, lpool, leaf, fils, dad, myid, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, keep, keep8, dkeep, iflag, ierror, comm, comm_load, itloc, rhs_mumps, nd, procnode_steps, slavef, opassw)
Definition zfac_process_contrib_type3.F:26
zmumps_insert_pool_n
subroutine zmumps_insert_pool_n(n, pool, lpool, procnode, slavef, keep199, k28, k76, k80, k47, step, inode)
Definition zfac_sol_pool.F:27
zmumps_root_alloc_static
subroutine zmumps_root_alloc_static(root, iroot, n, iw, liw, a, la, fils, dad, myid, slavef, procnode_steps, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, itloc, rhs_mumps, comp, lrlus, iflag, keep, keep8, dkeep, ierror)
Definition ztype3_root.F:1089
zmumps_ass_root
subroutine zmumps_ass_root(root, keep50, nrow_son, ncol_son, indrow_son, indcol_son, nsupcol, val_son, val_root, local_m, local_n, rhs_root, nloc_root, cbp)
Definition ztype3_root.F:19