OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
cfac_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 cmumps_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 cmumps_load
27 USE cmumps_ooc
28 USE cmumps_struc_def, ONLY : cmumps_root_struc
29 IMPLICIT NONE
30 TYPE (CMUMPS_ROOT_STRUC ) :: root
31 INTEGER :: KEEP( 500 )
32 INTEGER(8) :: KEEP8(150)
33 REAL :: 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 :: 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 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 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 cmumps_ooc_force_wrt_buf_panel(ierr)
108 ELSEIF (keep(201).EQ.2) THEN
109 CALL cmumps_force_write_buf(ierr)
110 ENDIF
111 CALL cmumps_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 cmumps_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 cmumps_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 CMUMPS_PROCESS_CONTRIB_TYPE3'
168 CALL mumps_abort()
169 ENDIF
170 CALL cmumps_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_complex, comm, ierr )
184 opassw = opassw + lreqa
185 CALL cmumps_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 cmumps_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 CMUMPS_PROCESS_CONTRIB_TYPE3'
207 CALL mumps_abort()
208 ENDIF
209 IF (lreqa.NE.0_8) THEN
210 CALL cmumps_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_complex, comm, ierr )
224 opassw = opassw + lreqa
225 IF (keep(60).EQ.0) THEN
226 CALL cmumps_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 cmumps_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 cmumps_load_mem_update(.false.,.false.,
253 & la-lrlus,0_8,-lreqa,keep,keep8,lrlus)
254 ENDIF
255 RETURN
256 END SUBROUTINE cmumps_process_contrib_type3
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
cmumps_alloc_cb
subroutine cmumps_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 cfac_mem_alloc_cb.F:23
cmumps_process_contrib_type3
subroutine cmumps_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 cfac_process_contrib_type3.F:26
cmumps_insert_pool_n
subroutine cmumps_insert_pool_n(n, pool, lpool, procnode, slavef, keep199, k28, k76, k80, k47, step, inode)
Definition cfac_sol_pool.F:27
cmumps_ass_root
subroutine cmumps_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 ctype3_root.F:19
cmumps_root_alloc_static
subroutine cmumps_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 ctype3_root.F:1089
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
cmumps_load
Definition cmumps_load.F:14
cmumps_load::cmumps_load_pool_upd_new_pool
subroutine, public cmumps_load_pool_upd_new_pool(pool, lpool, procnode, keep, keep8, slavef, comm, myid, step, n, nd, fils)
Definition cmumps_load.F:1820
cmumps_load::cmumps_load_mem_update
subroutine, public cmumps_load_mem_update(ssarbr, process_bande_arg, mem_value, new_lu, inc_mem_arg, keep, keep8, lrlus)
Definition cmumps_load.F:920
cmumps_ooc
Definition cmumps_ooc.F:14
cmumps_ooc::cmumps_force_write_buf
subroutine cmumps_force_write_buf(ierr)
Definition cmumps_ooc.F:2951
cmumps_ooc::cmumps_ooc_force_wrt_buf_panel
subroutine cmumps_ooc_force_wrt_buf_panel(ierr)
Definition cmumps_ooc.F:2965
cmumps_struc_def
Definition cmumps_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