39 IMPLICIT NONE
40 INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH
41 INTEGER PB_MAX_LENGTH
42 parameter(ooc_prefix_max_length=63, ooc_tmpdir_max_length=255)
43 parameter(pb_max_length=255)
44 INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 255
45 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255
46 INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT,
47 & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER,
48 & NRHS, LRHS,
49 & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, LREDRHS
50 INTEGER(8) :: NNZ, NNZ_loc
51 INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500)
52 INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD
53 INTEGER MBLOCK, NBLOCK, NPROW, NPCOL
54 INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN
55 REAL CNTL(15), RINFO(40), RINFOG(40), DKEEP(230)
56 INTEGER(8) KEEP8(150)
57 INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*)
58 INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*)
59 INTEGER, TARGET :: LISTVAR_SCHUR(*)
60 INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*)
61 INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*)
62 INTEGER, TARGET :: BLKPTR(*), BLKVAR(*)
63 REAL, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*)
64 REAL, TARGET :: WK_USER(*)
65 REAL, TARGET :: REDRHS(*)
66 REAL, TARGET :: ROWSCA(*), COLSCA(*)
67 REAL, TARGET :: SCHUR(*)
68 REAL, TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*)
69 INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH)
70 INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH)
71 INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH)
72 INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN
73 INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH)
74 INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH)
75 INTEGER METIS_OPTIONS(40)
76 INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere,
77 & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere,
78 & WK_USERhere,
79 & RHShere, REDRHShere, IRN_lochere,
80 & JCN_lochere, A_lochere, LISTVAR_SCHURhere,
81 & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere,
82 & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere,
83 & ISOL_lochere, IRHS_lochere
84 include 'mpif.h'
85 TYPE smumps_struc_ptr
86 TYPE (SMUMPS_STRUC), POINTER :: PTR
87 END TYPE smumps_struc_ptr
88 TYPE (SMUMPS_STRUC), POINTER :: mumps_par
89 TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE ::
90 & mumps_par_array
91 TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER ::
92 & mumps_par_array_bis
93 INTEGER, SAVE :: SMUMPS_STRUC_ARRAY_SIZE = 0
94 INTEGER, SAVE :: N_INSTANCES = 0
95 INTEGER I, Np, IERR
96 INTEGER(8) :: A_ELT_SIZE, NNZ_i
97 INTEGER SMUMPS_STRUC_ARRAY_SIZE_INIT
98 parameter(smumps_struc_array_size_init=10)
99 EXTERNAL mumps_assign_mapping,
100 & mumps_assign_pivnul_list,
101 & mumps_assign_sym_perm,
102 & mumps_assign_uns_perm
103 EXTERNAL smumps_assign_colsca,
104 & smumps_assign_rowsca
105 IF (job == -1) THEN
106 DO i = 1, smumps_struc_array_size
107 IF ( .NOT. associated(mumps_par_array(i)%PTR) ) GOTO 10
108 END DO
109 ALLOCATE( mumps_par_array_bis(smumps_struc_array_size +
110 & smumps_struc_array_size_init), stat=ierr)
111 IF (ierr /= 0) THEN
112 WRITE(*,*) ' ** Allocation Error 1 in SMUMPS_F77.'
114 END IF
115 DO i = 1, smumps_struc_array_size
116 mumps_par_array_bis(i)%PTR=>mumps_par_array(i)%PTR
117 ENDDO
118 IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array)
119 mumps_par_array=>mumps_par_array_bis
120 NULLIFY(mumps_par_array_bis)
121 DO i = smumps_struc_array_size+1, smumps_struc_array_size +
122 & smumps_struc_array_size_init
123 NULLIFY(mumps_par_array(i)%PTR)
124 ENDDO
125 i = smumps_struc_array_size+1
126 smumps_struc_array_size = smumps_struc_array_size +
127 & smumps_struc_array_size_init
128 10 CONTINUE
129 instance_number = i
130 n_instances = n_instances+1
131 ALLOCATE( mumps_par_array(instance_number)%PTR,stat=ierr )
132 IF (ierr /= 0) THEN
133 WRITE(*,*) '** Allocation Error 2 in SMUMPS_F77.'
135 ENDIF
136 icntl(1:60) = 0
137 cntl(1:15) = 0.0e0
138 keep(1:500) = 0
139 dkeep(1:230) = 0.0e0
140 keep8(1:150) = 0_8
141 metis_options(1:40) = 0
142 mumps_par_array(instance_number)%PTR%INSTANCE_NUMBER =
143 & instance_number
144 END IF
145 IF ( instance_number .LE. 0 .OR. instance_number .GT.
146 & smumps_struc_array_size ) THEN
147 WRITE(*,*) ' ** Instance Error 1 in SMUMPS_F77',
148 & instance_number
150 END IF
151 IF ( .NOT. associated ( mumps_par_array(instance_number)%PTR ) )
152 & THEN
153 WRITE(*,*) ' Instance Error 2 in SMUMPS_F77',
154 & instance_number
156 END IF
157 mumps_par => mumps_par_array(instance_number)%PTR
158 mumps_par%SYM = sym
159 mumps_par%PAR = par
160 mumps_par%JOB = job
161 mumps_par%N = n
162 mumps_par%NBLK = nblk
163 mumps_par%NZ = nz
164 mumps_par%NNZ = nnz
165 mumps_par%NZ_loc = nz_loc
166 mumps_par%NNZ_loc = nnz_loc
167 mumps_par%LWK_USER = lwk_user
168 mumps_par%SIZE_SCHUR = size_schur
169 mumps_par%NELT= nelt
170 mumps_par%ICNTL(1:60)=icntl(1:60)
171 mumps_par%CNTL(1:15)=cntl(1:15)
172 mumps_par%KEEP(1:500)=keep(1:500)
173 mumps_par%DKEEP(1:230)=dkeep(1:230)
174 mumps_par%KEEP8(1:150)=keep8(1:150)
175 mumps_par%METIS_OPTIONS(1:40)=metis_options(1:40)
176 mumps_par%NRHS = nrhs
177 mumps_par%LRHS = lrhs
178 mumps_par%LREDRHS = lredrhs
179 mumps_par%NZ_RHS = nz_rhs
180 mumps_par%LSOL_loc = lsol_loc
181 mumps_par%Nloc_RHS = nloc_rhs
182 mumps_par%LRHS_loc = lrhs_loc
183 mumps_par%SCHUR_MLOC = schur_mloc
184 mumps_par%SCHUR_NLOC = schur_nloc
185 mumps_par%SCHUR_LLD = schur_lld
186 mumps_par%MBLOCK = mblock
187 mumps_par%NBLOCK = nblock
188 mumps_par%NPROW = nprow
189 mumps_par%NPCOL = npcol
190 IF ( comm_f77 .NE. -987654 ) THEN
191 mumps_par%COMM = comm_f77
192 ELSE
193 mumps_par%COMM = mpi_comm_world
194 ENDIF
195 CALL mpi_bcast(nrhs,1,mpi_integer,0,mumps_par%COMM,ierr)
197 IF ( irnhere /= 0 ) mumps_par%IRN => irn(1:nnz_i)
198 IF ( jcnhere /= 0 ) mumps_par%JCN => jcn(1:nnz_i)
199 IF ( ahere /= 0 ) mumps_par%A => a(1:nnz_i)
201 IF ( irn_lochere /= 0 ) mumps_par%IRN_loc => irn_loc(1:nnz_i)
202 IF ( jcn_lochere /= 0 ) mumps_par%JCN_loc => jcn_loc(1:nnz_i)
203 IF ( a_lochere /= 0 ) mumps_par%A_loc => a_loc(1:nnz_i)
204 IF ( eltptrhere /= 0 ) mumps_par%ELTPTR => eltptr(1:nelt+1)
205 IF ( eltvarhere /= 0 ) mumps_par%ELTVAR =>
206 & eltvar(1:eltptr(nelt+1)-1)
207 IF ( a_elthere /= 0 ) THEN
208 a_elt_size = 0_8
209 DO i = 1, nelt
210 np = eltptr(i+1) -eltptr(i)
211 IF (sym == 0) THEN
212 a_elt_size = a_elt_size + np * np
213 ELSE
214 a_elt_size = a_elt_size + np * ( np + 1 ) / 2
215 END IF
216 END DO
217 mumps_par%A_ELT => a_elt(1_8:a_elt_size)
218 END IF
219 IF ( blkptrhere /= 0 ) mumps_par%BLKPTR => blkptr(1:nblk+1)
220 IF ( blkvarhere /= 0 ) mumps_par%BLKVAR => blkvar(1:n)
221 IF ( perm_inhere /= 0) mumps_par%PERM_IN => perm_in(1:n)
222 IF ( listvar_schurhere /= 0)
223 & mumps_par%LISTVAR_SCHUR =>listvar_schur(1:size_schur)
224 IF ( schurhere /= 0 ) THEN
225 mumps_par%SCHUR_CINTERFACE=>schur(1:1)
226 ENDIF
227 IF (nrhs .NE. 1) THEN
228 IF ( rhshere /= 0 ) mumps_par%RHS =>
229 & rhs(1_8:int(nrhs,8)*int(lrhs,8))
230 IF (redrhshere /= 0)mumps_par%REDRHS=>
231 & redrhs(1_8:int(nrhs,8)*int(lredrhs,8))
232 ELSE
233 IF ( rhshere /= 0 ) mumps_par%RHS => rhs(1:n)
234 IF (redrhshere /= 0)mumps_par%REDRHS=>redrhs(1:size_schur)
235 ENDIF
236 IF ( wk_userhere /=0 ) THEN
237 IF (lwk_user > 0 ) THEN
238 mumps_par%WK_USER => wk_user(1:lwk_user)
239 ELSE
240 mumps_par%WK_USER => wk_user(1_8:-int(lwk_user,8)*1000000_8)
241 ENDIF
242 ENDIF
243 IF ( colscahere /= 0) mumps_par%COLSCA => colsca(1:n)
244 IF ( rowscahere /= 0) mumps_par%ROWSCA => rowsca(1:n)
245 IF ( rhs_sparsehere /=0 ) mumps_par%RHS_SPARSE=>
246 & rhs_sparse(1:nz_rhs)
247 IF ( irhs_sparsehere /=0 ) mumps_par%IRHS_SPARSE=>
248 & irhs_sparse(1:nz_rhs)
249 IF ( sol_lochere /=0 ) mumps_par%SOL_loc=>
250 & sol_loc(1_8:int(lsol_loc,8)*int(nrhs,8))
251 IF ( rhs_lochere /=0 ) mumps_par%RHS_loc=>
252 & rhs_loc(1_8:int(lrhs_loc,8)*int(nrhs,8))
253 IF ( isol_lochere /=0 ) mumps_par%ISOL_loc=>
254 & isol_loc(1:lsol_loc)
255 IF ( irhs_lochere /=0 ) mumps_par%IRHS_loc=>
256 & irhs_loc(1:lrhs_loc)
257 IF ( irhs_ptrhere /=0 ) mumps_par%IRHS_PTR=>
258 & irhs_ptr(1:nrhs+1)
259 DO i=1,tmpdirlen
260 mumps_par%OOC_TMPDIR(i:i)=char(ooc_tmpdir(i))
261 ENDDO
262 DO i=tmpdirlen+1,ooc_tmpdir_max_length
263 mumps_par%OOC_TMPDIR(i:i)=' '
264 ENDDO
265 DO i=1,prefixlen
266 mumps_par%OOC_PREFIX(i:i)=char(ooc_prefix(i))
267 ENDDO
268 DO i=prefixlen+1,ooc_prefix_max_length
269 mumps_par%OOC_PREFIX(i:i)=' '
270 ENDDO
271 DO i=1,write_problemlen
272 mumps_par%WRITE_PROBLEM(i:i)=char(write_problem(i))
273 ENDDO
274 DO i=write_problemlen+1,pb_max_length
275 mumps_par%WRITE_PROBLEM(i:i)=' '
276 ENDDO
277 DO i=1,save_dirlen
278 mumps_par%SAVE_DIR(i:i)=char(save_dir(i))
279 ENDDO
280 DO i=save_dirlen+1,save_dir_max_length
281 mumps_par%SAVE_DIR(i:i)=' '
282 ENDDO
283 DO i=1,save_prefixlen
284 mumps_par%SAVE_PREFIX(i:i)=char(save_prefix(i))
285 ENDDO
286 DO i=save_prefixlen+1,save_prefix_max_length
287 mumps_par%SAVE_PREFIX(i:i)=' '
288 ENDDO
290 info(1:80)=mumps_par%INFO(1:80)
291 infog(1:80)=mumps_par%INFOG(1:80)
292 rinfo(1:40)=mumps_par%RINFO(1:40)
293 rinfog(1:40)=mumps_par%RINFOG(1:40)
294 icntl(1:60) = mumps_par%ICNTL(1:60)
295 cntl(1:15) = mumps_par%CNTL(1:15)
296 keep(1:500) = mumps_par%KEEP(1:500)
297 dkeep(1:230) = mumps_par%DKEEP(1:230)
298 keep8(1:150) = mumps_par%KEEP8(1:150)
299 metis_options(1:40) = mumps_par%METIS_OPTIONS(1:40)
300 sym = mumps_par%SYM
301 par = mumps_par%PAR
302 job = mumps_par%JOB
303 n = mumps_par%N
304 nblk = mumps_par%NBLK
305 nz = mumps_par%NZ
306 nnz = mumps_par%NNZ
307 nrhs = mumps_par%NRHS
308 lrhs = mumps_par%LRHS
309 lredrhs = mumps_par%LREDRHS
310 nz_loc = mumps_par%NZ_loc
311 nnz_loc = mumps_par%NNZ_loc
312 nz_rhs = mumps_par%NZ_RHS
313 lsol_loc = mumps_par%LSOL_loc
314 nloc_rhs = mumps_par%Nloc_RHS
315 lrhs_loc = mumps_par%LRHS_loc
316 size_schur = mumps_par%SIZE_SCHUR
317 lwk_user = mumps_par%LWK_USER
318 nelt = mumps_par%NELT
319 deficiency = mumps_par%Deficiency
320 schur_mloc = mumps_par%SCHUR_MLOC
321 schur_nloc = mumps_par%SCHUR_NLOC
322 schur_lld = mumps_par%SCHUR_LLD
323 mblock = mumps_par%MBLOCK
324 nblock = mumps_par%NBLOCK
325 nprow = mumps_par%NPROW
326 npcol = mumps_par%NPCOL
327 IF ( associated (mumps_par%MAPPING) ) THEN
328 CALL mumps_assign_mapping(mumps_par%MAPPING(1))
329 ELSE
330 CALL mumps_nullify_c_mapping()
331 ENDIF
332 IF ( associated (mumps_par%PIVNUL_LIST) ) THEN
333 CALL mumps_assign_pivnul_list(mumps_par%PIVNUL_LIST(1))
334 ELSE
335 CALL mumps_nullify_c_pivnul_list()
336 ENDIF
337 IF ( associated (mumps_par%SYM_PERM) ) THEN
338 CALL mumps_assign_sym_perm(mumps_par%SYM_PERM(1))
339 ELSE
340 CALL mumps_nullify_c_sym_perm()
341 ENDIF
342 IF ( associated (mumps_par%UNS_PERM) ) THEN
343 CALL mumps_assign_uns_perm(mumps_par%UNS_PERM(1))
344 ELSE
345 CALL mumps_nullify_c_uns_perm()
346 ENDIF
347 IF (associated( mumps_par%COLSCA)) THEN
348 CALL smumps_assign_colsca(mumps_par%COLSCA(1))
349 ELSE
350 CALL smumps_nullify_c_colsca()
351 ENDIF
352 IF (associated( mumps_par%ROWSCA)) THEN
353 CALL smumps_assign_rowsca(mumps_par%ROWSCA(1))
354 ELSE
355 CALL smumps_nullify_c_rowsca()
356 ENDIF
357 tmpdirlen=len_trim(mumps_par%OOC_TMPDIR)
358 DO i=1,ooc_tmpdir_max_length
359 ooc_tmpdir(i)=ichar(mumps_par%OOC_TMPDIR(i:i))
360 ENDDO
361 prefixlen=len_trim(mumps_par%OOC_PREFIX)
362 DO i=1,ooc_prefix_max_length
363 ooc_prefix(i)=ichar(mumps_par%OOC_PREFIX(i:i))
364 ENDDO
365 IF ( job == -2 ) THEN
366 IF (associated(mumps_par_array(instance_number)%PTR))THEN
367 DEALLOCATE(mumps_par_array(instance_number)%PTR)
368 NULLIFY (mumps_par_array(instance_number)%PTR)
369 n_instances = n_instances - 1
370 IF ( n_instances == 0 ) THEN
371 DEALLOCATE(mumps_par_array)
372 smumps_struc_array_size = 0
373 END IF
374 ELSE
375 WRITE(*,*) "** Warning: instance already freed"
376 WRITE(*,*) " this should normally not happen."
377 ENDIF
378 END IF
379 RETURN
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
1.15.0