1C 2C This file is part of MUMPS 5.1.2, released 3C on Mon Oct 2 07:37:01 UTC 2017 4C 5C 6C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, 7C 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 http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html 12C 13 SUBROUTINE SMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, ICNTL, CNTL, 14 & KEEP, DKEEP, KEEP8, 15 & NZ, NNZ, IRN, IRNhere, JCN, JCNhere, 16 & A, Ahere, 17 & NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, 18 & JCN_loc, JCN_lochere, 19 & A_loc, A_lochere, 20 & NELT, ELTPTR, ELTPTRhere, ELTVAR, 21 & ELTVARhere, A_ELT, A_ELThere, 22 & PERM_IN, PERM_INhere, 23 & RHS, RHShere, REDRHS, REDRHShere, 24 & INFO, RINFO, INFOG, RINFOG, 25 & DEFICIENCY, LWK_USER, 26 & SIZE_SCHUR, LISTVAR_SCHUR, 27 & LISTVAR_SCHURhere, SCHUR, SCHURhere, 28 & WK_USER, WK_USERhere, 29 & COLSCA, COLSCAhere, ROWSCA, ROWSCAhere, 30 & INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, 31 & 32 & RHS_SPARSE, RHS_SPARSEhere, 33 & SOL_loc, SOL_lochere, 34 & IRHS_SPARSE, IRHS_SPARSEhere, 35 & IRHS_PTR, IRHS_PTRhere, 36 & ISOL_loc, ISOL_lochere, 37 & NZ_RHS, LSOL_loc 38 & , 39 & SCHUR_MLOC, 40 & SCHUR_NLOC, 41 & SCHUR_LLD, 42 & MBLOCK, 43 & NBLOCK, 44 & NPROW, 45 & NPCOL, 46 & 47 & OOC_TMPDIR, 48 & OOC_PREFIX, 49 & WRITE_PROBLEM, 50 & TMPDIRLEN, 51 & PREFIXLEN, 52 & WRITE_PROBLEMLEN 53 & 54 & ) 55 USE SMUMPS_STRUC_DEF 56 IMPLICIT NONE 57 INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH 58 INTEGER PB_MAX_LENGTH 59 PARAMETER(OOC_PREFIX_MAX_LENGTH=63, OOC_TMPDIR_MAX_LENGTH=255) 60 PARAMETER(PB_MAX_LENGTH=255) 61 INTEGER JOB, SYM, PAR, COMM_F77, N, NZ, NZ_loc, NELT, 62 & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, 63 & NRHS, LRHS, 64 & NZ_RHS, LSOL_loc, LREDRHS 65 INTEGER(8) :: NNZ, NNZ_loc 66 INTEGER ICNTL(40), INFO(40), INFOG(40), KEEP(500) 67 INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD 68 INTEGER MBLOCK, NBLOCK, NPROW, NPCOL 69 INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN 70 REAL CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) 71 INTEGER(8) KEEP8(150) 72 INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) 73 INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) 74 INTEGER, TARGET :: LISTVAR_SCHUR(*) 75 INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*), ISOL_loc(*) 76 REAL, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) 77 REAL, TARGET :: WK_USER(*) 78 REAL, TARGET :: REDRHS(*) 79 REAL, TARGET :: ROWSCA(*), COLSCA(*) 80 REAL, TARGET :: SCHUR(*) 81 REAL, TARGET :: RHS_SPARSE(*), SOL_loc(*) 82 INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) 83 INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) 84 INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) 85 INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, 86 & A_ELThere, PERM_INhere, WK_USERhere, 87 & RHShere, REDRHShere, IRN_lochere, 88 & JCN_lochere, A_lochere, LISTVAR_SCHURhere, 89 & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, 90 & SOL_lochere, IRHS_PTRhere, IRHS_SPARSEhere, ISOL_lochere 91 INCLUDE 'mpif.h' 92 TYPE SMUMPS_STRUC_PTR 93 TYPE (SMUMPS_STRUC), POINTER :: PTR 94 END TYPE SMUMPS_STRUC_PTR 95 TYPE (SMUMPS_STRUC), POINTER :: mumps_par 96 TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: 97 & mumps_par_array 98 TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: 99 & mumps_par_array_bis 100 INTEGER, SAVE :: SMUMPS_STRUC_ARRAY_SIZE = 0 101 INTEGER, SAVE :: N_INSTANCES = 0 102 INTEGER A_ELT_SIZE, I, Np, IERR 103 INTEGER(8) :: NNZ_i 104 INTEGER SMUMPS_STRUC_ARRAY_SIZE_INIT 105 PARAMETER (SMUMPS_STRUC_ARRAY_SIZE_INIT=10) 106 EXTERNAL MUMPS_ASSIGN_MAPPING, 107 & MUMPS_ASSIGN_PIVNUL_LIST, 108 & MUMPS_ASSIGN_SYM_PERM, 109 & MUMPS_ASSIGN_UNS_PERM 110 EXTERNAL SMUMPS_ASSIGN_COLSCA, 111 & SMUMPS_ASSIGN_ROWSCA 112 IF (JOB == -1) THEN 113 DO I = 1, SMUMPS_STRUC_ARRAY_SIZE 114 IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 115 END DO 116 ALLOCATE( mumps_par_array_bis(SMUMPS_STRUC_ARRAY_SIZE + 117 & SMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) 118 IF (IERR /= 0) THEN 119 WRITE(*,*) ' ** Allocation Error 1 in SMUMPS_F77.' 120 CALL MUMPS_ABORT() 121 END IF 122 DO I = 1, SMUMPS_STRUC_ARRAY_SIZE 123 mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR 124 ENDDO 125 IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) 126 mumps_par_array=>mumps_par_array_bis 127 NULLIFY(mumps_par_array_bis) 128 DO I = SMUMPS_STRUC_ARRAY_SIZE+1, SMUMPS_STRUC_ARRAY_SIZE + 129 & SMUMPS_STRUC_ARRAY_SIZE_INIT 130 NULLIFY(mumps_par_array(I)%PTR) 131 ENDDO 132 I = SMUMPS_STRUC_ARRAY_SIZE+1 133 SMUMPS_STRUC_ARRAY_SIZE = SMUMPS_STRUC_ARRAY_SIZE + 134 & SMUMPS_STRUC_ARRAY_SIZE_INIT 135 10 CONTINUE 136 INSTANCE_NUMBER = I 137 N_INSTANCES = N_INSTANCES+1 138 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) 139 IF (IERR /= 0) THEN 140 WRITE(*,*) '** Allocation Error 2 in SMUMPS_F77.' 141 CALL MUMPS_ABORT() 142 ENDIF 143 mumps_par_array(INSTANCE_NUMBER)%PTR%KEEP(40) = 0 144 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = 145 & INSTANCE_NUMBER 146 END IF 147 IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. 148 & SMUMPS_STRUC_ARRAY_SIZE ) THEN 149 WRITE(*,*) ' ** Instance Error 1 in SMUMPS_F77', 150 & INSTANCE_NUMBER 151 CALL MUMPS_ABORT() 152 END IF 153 IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) 154 & THEN 155 WRITE(*,*) ' Instance Error 2 in SMUMPS_F77', 156 & INSTANCE_NUMBER 157 CALL MUMPS_ABORT() 158 END IF 159 mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR 160 mumps_par%SYM = SYM 161 mumps_par%PAR = PAR 162 mumps_par%JOB = JOB 163 mumps_par%N = N 164 mumps_par%NZ = NZ 165 mumps_par%NNZ = NNZ 166 mumps_par%NZ_loc = NZ_loc 167 mumps_par%NNZ_loc = NNZ_loc 168 mumps_par%LWK_USER = LWK_USER 169 mumps_par%SIZE_SCHUR = SIZE_SCHUR 170 mumps_par%NELT= NELT 171 mumps_par%ICNTL(1:40)=ICNTL(1:40) 172 mumps_par%CNTL(1:15)=CNTL(1:15) 173 mumps_par%KEEP(1:500)=KEEP(1:500) 174 mumps_par%DKEEP(1:230)=DKEEP(1:230) 175 mumps_par%KEEP8(1:150)=KEEP8(1:150) 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%SCHUR_MLOC = SCHUR_MLOC 182 mumps_par%SCHUR_NLOC = SCHUR_NLOC 183 mumps_par%SCHUR_LLD = SCHUR_LLD 184 mumps_par%MBLOCK = MBLOCK 185 mumps_par%NBLOCK = NBLOCK 186 mumps_par%NPROW = NPROW 187 mumps_par%NPCOL = NPCOL 188 IF ( COMM_F77 .NE. -987654 ) THEN 189 mumps_par%COMM = COMM_F77 190 ELSE 191 mumps_par%COMM = MPI_COMM_WORLD 192 ENDIF 193 CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) 194 CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) 195 IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) 196 IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) 197 IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) 198 CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) 199 IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) 200 IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) 201 IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) 202 IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) 203 IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => 204 & ELTVAR(1:ELTPTR(NELT+1)-1) 205 IF ( A_ELThere /= 0 ) THEN 206 A_ELT_SIZE = 0 207 DO I = 1, NELT 208 Np = ELTPTR(I+1) -ELTPTR(I) 209 IF (SYM == 0) THEN 210 A_ELT_SIZE = A_ELT_SIZE + Np * Np 211 ELSE 212 A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 213 END IF 214 END DO 215 mumps_par%A_ELT => A_ELT(1:A_ELT_SIZE) 216 END IF 217 IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) 218 IF ( LISTVAR_SCHURhere /= 0) 219 & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) 220 IF ( SCHURhere /= 0 ) THEN 221 mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) 222 ENDIF 223 IF (NRHS .NE. 1) THEN 224 IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:NRHS*LRHS) 225 IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:NRHS*LREDRHS) 226 ELSE 227 IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) 228 IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) 229 ENDIF 230 IF ( WK_USERhere /=0 ) THEN 231 IF (LWK_USER > 0 ) THEN 232 mumps_par%WK_USER => WK_USER(1:LWK_USER) 233 ELSE 234 mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) 235 ENDIF 236 ENDIF 237 IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) 238 IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) 239 IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> 240 & RHS_SPARSE(1:NZ_RHS) 241 IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> 242 & IRHS_SPARSE(1:NZ_RHS) 243 IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> 244 & SOL_loc(1:LSOL_loc*NRHS) 245 IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> 246 & ISOL_loc(1:LSOL_loc) 247 IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> 248 & IRHS_PTR(1:NRHS+1) 249 DO I=1,TMPDIRLEN 250 mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) 251 ENDDO 252 DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH 253 mumps_par%OOC_TMPDIR(I:I)=' ' 254 ENDDO 255 DO I=1,PREFIXLEN 256 mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) 257 ENDDO 258 DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH 259 mumps_par%OOC_PREFIX(I:I)=' ' 260 ENDDO 261 DO I=1,WRITE_PROBLEMLEN 262 mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) 263 ENDDO 264 DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH 265 mumps_par%WRITE_PROBLEM(I:I)=' ' 266 ENDDO 267 CALL SMUMPS( mumps_par ) 268 INFO(1:40)=mumps_par%INFO(1:40) 269 INFOG(1:40)=mumps_par%INFOG(1:40) 270 RINFO(1:40)=mumps_par%RINFO(1:40) 271 RINFOG(1:40)=mumps_par%RINFOG(1:40) 272 ICNTL(1:40) = mumps_par%ICNTL(1:40) 273 CNTL(1:15) = mumps_par%CNTL(1:15) 274 KEEP(1:500) = mumps_par%KEEP(1:500) 275 DKEEP(1:230) = mumps_par%DKEEP(1:230) 276 KEEP8(1:150) = mumps_par%KEEP8(1:150) 277 SYM = mumps_par%SYM 278 PAR = mumps_par%PAR 279 JOB = mumps_par%JOB 280 N = mumps_par%N 281 NZ = mumps_par%NZ 282 NNZ = mumps_par%NNZ 283 NRHS = mumps_par%NRHS 284 LRHS = mumps_par%LRHS 285 LREDRHS = mumps_par%LREDRHS 286 NZ_loc = mumps_par%NZ_loc 287 NNZ_loc = mumps_par%NNZ_loc 288 NZ_RHS = mumps_par%NZ_RHS 289 LSOL_loc= mumps_par%LSOL_loc 290 SIZE_SCHUR = mumps_par%SIZE_SCHUR 291 LWK_USER = mumps_par%LWK_USER 292 NELT= mumps_par%NELT 293 DEFICIENCY = mumps_par%Deficiency 294 SCHUR_MLOC = mumps_par%SCHUR_MLOC 295 SCHUR_NLOC = mumps_par%SCHUR_NLOC 296 SCHUR_LLD = mumps_par%SCHUR_LLD 297 MBLOCK = mumps_par%MBLOCK 298 NBLOCK = mumps_par%NBLOCK 299 NPROW = mumps_par%NPROW 300 NPCOL = mumps_par%NPCOL 301 IF ( associated (mumps_par%MAPPING) ) THEN 302 CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) 303 ELSE 304 CALL MUMPS_NULLIFY_C_MAPPING() 305 ENDIF 306 IF ( associated (mumps_par%PIVNUL_LIST) ) THEN 307 CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) 308 ELSE 309 CALL MUMPS_NULLIFY_C_PIVNUL_LIST() 310 ENDIF 311 IF ( associated (mumps_par%SYM_PERM) ) THEN 312 CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) 313 ELSE 314 CALL MUMPS_NULLIFY_C_SYM_PERM() 315 ENDIF 316 IF ( associated (mumps_par%UNS_PERM) ) THEN 317 CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) 318 ELSE 319 CALL MUMPS_NULLIFY_C_UNS_PERM() 320 ENDIF 321 IF (associated( mumps_par%COLSCA)) THEN 322 CALL SMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) 323 ELSE 324 CALL SMUMPS_NULLIFY_C_COLSCA() 325 ENDIF 326 IF (associated( mumps_par%ROWSCA)) THEN 327 CALL SMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) 328 ELSE 329 CALL SMUMPS_NULLIFY_C_ROWSCA() 330 ENDIF 331 TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) 332 DO I=1,OOC_TMPDIR_MAX_LENGTH 333 OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) 334 ENDDO 335 PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) 336 DO I=1,OOC_PREFIX_MAX_LENGTH 337 OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) 338 ENDDO 339 IF ( JOB == -2 ) THEN 340 IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN 341 DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) 342 NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) 343 N_INSTANCES = N_INSTANCES - 1 344 IF ( N_INSTANCES == 0 ) THEN 345 DEALLOCATE(mumps_par_array) 346 SMUMPS_STRUC_ARRAY_SIZE = 0 347 END IF 348 ELSE 349 WRITE(*,*) "** Warning: instance already freed" 350 WRITE(*,*) " this should normally not happen." 351 ENDIF 352 END IF 353 RETURN 354 END SUBROUTINE SMUMPS_F77 355