OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
cmumps_f77.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_f77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL,
15 & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN,
16 & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere,
17 & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR,
18 & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere,
19 & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere,
20 & PERM_IN, PERM_INhere, RHS, RHShere, REDRHS, REDRHShere,
21 & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER,
22 & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR,
23 & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere,
24 & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS,
25 & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere,
26 & RHS_loc, RHS_lochere,
27 & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere,
28 & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS,
29 & LSOL_loc, LRHS_loc, Nloc_RHS,
30 & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD,
31 & MBLOCK, NBLOCK, NPROW, NPCOL,
32 & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM,
33 & SAVE_DIR, SAVE_PREFIX,
34 & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN,
35 & SAVE_DIRLEN, SAVE_PREFIXLEN,
36 & METIS_OPTIONS
37 & )
38 USE cmumps_struc_def
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 COMPLEX, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*)
64 COMPLEX, TARGET :: WK_USER(*)
65 COMPLEX, TARGET :: REDRHS(*)
66 REAL, TARGET :: ROWSCA(*), COLSCA(*)
67 COMPLEX, TARGET :: SCHUR(*)
68 COMPLEX, 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 cmumps_struc_ptr
86 TYPE (CMUMPS_STRUC), POINTER :: PTR
87 END TYPE cmumps_struc_ptr
88 TYPE (CMUMPS_STRUC), POINTER :: mumps_par
89 TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE ::
90 & mumps_par_array
91 TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER ::
92 & mumps_par_array_bis
93 INTEGER, SAVE :: CMUMPS_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 CMUMPS_STRUC_ARRAY_SIZE_INIT
98 parameter(cmumps_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 cmumps_assign_colsca,
104 & cmumps_assign_rowsca
105 IF (job == -1) THEN
106 DO i = 1, cmumps_struc_array_size
107 IF ( .NOT. associated(mumps_par_array(i)%PTR) ) GOTO 10
108 END DO
109 ALLOCATE( mumps_par_array_bis(cmumps_struc_array_size +
110 & cmumps_struc_array_size_init), stat=ierr)
111 IF (ierr /= 0) THEN
112 WRITE(*,*) ' ** Allocation Error 1 in CMUMPS_F77.'
113 CALL mumps_abort()
114 END IF
115 DO i = 1, cmumps_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 = cmumps_struc_array_size+1, cmumps_struc_array_size +
122 & cmumps_struc_array_size_init
123 NULLIFY(mumps_par_array(i)%PTR)
124 ENDDO
125 i = cmumps_struc_array_size+1
126 cmumps_struc_array_size = cmumps_struc_array_size +
127 & cmumps_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 CMUMPS_F77.'
134 CALL mumps_abort()
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 & cmumps_struc_array_size ) THEN
147 WRITE(*,*) ' ** Instance Error 1 in CMUMPS_F77',
148 & instance_number
149 CALL mumps_abort()
150 END IF
151 IF ( .NOT. associated ( mumps_par_array(instance_number)%PTR ) )
152 & THEN
153 WRITE(*,*) ' Instance Error 2 in CMUMPS_F77',
154 & instance_number
155 CALL mumps_abort()
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)
196 CALL mumps_get_nnz_internal(nnz,nz,nnz_i)
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)
200 CALL mumps_get_nnz_internal(nnz_loc,nz_loc,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
289 CALL cmumps( mumps_par )
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 cmumps_assign_colsca(mumps_par%COLSCA(1))
349 ELSE
350 CALL cmumps_nullify_c_colsca()
351 ENDIF
352 IF (associated( mumps_par%ROWSCA)) THEN
353 CALL cmumps_assign_rowsca(mumps_par%ROWSCA(1))
354 ELSE
355 CALL cmumps_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 cmumps_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
380 END SUBROUTINE cmumps_f77
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
cmumps
subroutine cmumps(id)
Definition cmumps_driver.F:20
cmumps_f77
subroutine cmumps_f77(job, sym, par, comm_f77, n, nblk, icntl, cntl, keep, dkeep, keep8, nz, nnz, irn, irnhere, jcn, jcnhere, a, ahere, nz_loc, nnz_loc, irn_loc, irn_lochere, jcn_loc, jcn_lochere, a_loc, a_lochere, nelt, eltptr, eltptrhere, eltvar, eltvarhere, a_elt, a_elthere, blkptr, blkptrhere, blkvar, blkvarhere, perm_in, perm_inhere, rhs, rhshere, redrhs, redrhshere, info, rinfo, infog, rinfog, deficiency, lwk_user, size_schur, listvar_schur, listvar_schurhere, schur, schurhere, wk_user, wk_userhere, colsca, colscahere, rowsca, rowscahere, instance_number, nrhs, lrhs, lredrhs, rhs_sparse, rhs_sparsehere, sol_loc, sol_lochere, rhs_loc, rhs_lochere, irhs_sparse, irhs_sparsehere, irhs_ptr, irhs_ptrhere, isol_loc, isol_lochere, irhs_loc, irhs_lochere, nz_rhs, lsol_loc, lrhs_loc, nloc_rhs, schur_mloc, schur_nloc, schur_lld, mblock, nblock, nprow, npcol, ooc_tmpdir, ooc_prefix, write_problem, save_dir, save_prefix, tmpdirlen, prefixlen, write_problemlen, save_dirlen, save_prefixlen, metis_options)
Definition cmumps_f77.F:38
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
cmumps_struc_def
Definition cmumps_struc_def.F:14
mumps_get_nnz_internal
subroutine mumps_get_nnz_internal(nnz, nz, nnz_i)
Definition tools_common.F:1248