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 CMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, 14 & MSGLEN, BUFR, LBUFR, 15 & LBUFR_BYTES, PROCNODE_STEPS, 16 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, 17 & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, 18 & STEP, PIMASTER, PAMASTER, NBPROCFILS, 19 & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, 20 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, 21 & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, 22 & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, 23 & FRTPTR, FRTELT, 24 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 25 & , LRGROUPS 26 & ) 27 USE CMUMPS_LOAD 28 USE CMUMPS_BUF 29 IMPLICIT NONE 30 INCLUDE 'cmumps_root.h' 31 TYPE (CMUMPS_ROOT_STRUC) :: root 32 INTEGER ICNTL( 40 ), KEEP( 500 ) 33 INTEGER(8) KEEP8(150) 34 REAL DKEEP(230) 35 INTEGER LBUFR, LBUFR_BYTES 36 INTEGER COMM_LOAD, ASS_IRECV, MSGLEN 37 INTEGER BUFR( LBUFR ) 38 INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC 39 INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW 40 INTEGER NBFIN 41 INTEGER COMP 42 INTEGER NELT, LPTRAR 43 INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) 44 INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) 45 INTEGER(8) :: PTRFAC(KEEP(28)) 46 INTEGER STEP(N), PIMASTER(KEEP(28)) 47 INTEGER PTLUST( KEEP(28) ) 48 INTEGER NBPROCFILS( KEEP(28) ) 49 INTEGER IW( LIW ) 50 COMPLEX A( LA ) 51 INTEGER, intent(in) :: LRGROUPS(N) 52 INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ), FILS( N ) 53 COMPLEX :: RHS_MUMPS(KEEP(255)) 54 INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) 55 INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 56 INTEGER INTARR( KEEP8(27) ) 57 COMPLEX DBLARR( KEEP8(26) ) 58 DOUBLE PRECISION OPASSW, OPELIW 59 INTEGER COMM, MYID, IFLAG, IERROR 60 INTEGER LEAF, LPOOL 61 INTEGER IPOOL( LPOOL ) 62 INTEGER FRTPTR(N+1), FRTELT( NELT ) 63 INTEGER ISTEP_TO_INIV2(KEEP(71)), 64 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 65 INTEGER NFS4FATHER 66 INCLUDE 'mumps_headers.h' 67 INCLUDE 'mpif.h' 68 INCLUDE 'mumps_tags.h' 69 INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT 70 EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT 71 INTEGER IERR 72 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET 73 INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL 74 INTEGER LREQI 75 INTEGER(8) :: LREQA, POSCONTRIB 76 INTEGER ROW_LENGTH 77 INTEGER MASTER 78 INTEGER ISTCHK 79 LOGICAL SAME_PROC 80 LOGICAL SLAVE_NODE 81 LOGICAL IS_ofType5or6 82 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC 83 INTEGER TYPESPLIT 84 INTEGER DECR 85#if ! defined(NO_XXNBPR) 86 INTEGER :: INBPROCFILS_SON 87#endif 88 POSITION = 0 89 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, 90 & MPI_INTEGER, COMM, IERR ) 91 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, ISON, 1, 92 & MPI_INTEGER, COMM, IERR ) 93 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBROW, 1, 94 & MPI_INTEGER, COMM, IERR ) 95 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LROW, 1, 96 & MPI_INTEGER, COMM, IERR ) 97 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 98 & NBROWS_ALREADY_SENT, 1, 99 & MPI_INTEGER, COMM, IERR ) 100 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 101 & NBROWS_PACKET, 1, 102 & MPI_INTEGER, COMM, IERR ) 103 MASTER = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF) 104 SLAVE_NODE = MASTER .NE. MYID 105 TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE)), 106 & SLAVEF) 107 IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) 108 IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN 109 ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) 110 LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 111 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) 112 CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, 113 & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, 114 & PROCNODE_STEPS, POSFAC, 115 & IWPOS, IWPOSCB, IPTRLU, 116 & LRLU, LRLUS, N, IW, LIW, A, LA, 117 & PTRIST, PTLUST, PTRFAC, 118 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 119 & IFLAG, IERROR, COMM, 120 & NBPROCFILS, IPOOL, LPOOL, LEAF, 121 & NBFIN, MYID, SLAVEF, 122 & 123 & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, 124 & PTRARW, PTRAIW, 125 & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, 126 & LPTRAR, NELT, FRTPTR, FRTELT, 127 & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 128 & , LRGROUPS 129 & ) 130 IF (IFLAG.LT.0) RETURN 131 ENDIF 132 IF ( SLAVE_NODE ) THEN 133 LREQI = LROW + NBROWS_PACKET 134 ELSE 135 LREQI = NBROWS_PACKET 136 END IF 137 LREQA = int(LROW,8) 138 IF ( LRLU .LT. LREQA .OR. IWPOS + LREQI 139 & - 1 .GT. IWPOSCB ) THEN 140 IF ( LRLUS .LT. LREQA ) THEN 141 IFLAG = -9 142 CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR ) 143 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 144 RETURN 145 END IF 146 CALL CMUMPS_COMPRE_NEW(N, KEEP(28), IW, LIW, A, LA, 147 & LRLU, IPTRLU, 148 & IWPOS, IWPOSCB, PTRIST, PTRAST, 149 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 150 & KEEP(IXSZ), COMP, DKEEP(97), MYID ) 151 IF ( LRLU .NE. LRLUS ) THEN 152 WRITE(*,*) 'PB compress CMUMPS_PROCESS_CONTRIB_TYPE2' 153 WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS 154 IFLAG = -9 155 CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR ) 156 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 157 RETURN 158 END IF 159 IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN 160 IFLAG = -8 161 IERROR = IWPOS + LREQI - 1 - IWPOSCB 162 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 163 RETURN 164 END IF 165 END IF 166 LRLU = LRLU - LREQA 167 LRLUS = LRLUS - LREQA 168 POSCONTRIB = POSFAC 169 POSFAC = POSFAC + LREQA 170 KEEP8(67) = min(LRLUS, KEEP8(67)) 171 KEEP8(70) = KEEP8(70) - LREQA 172 KEEP8(68) = min(KEEP8(70), KEEP8(68)) 173 KEEP8(71) = KEEP8(71) - LREQA 174 KEEP8(69) = min(KEEP8(71), KEEP8(69)) 175 CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., 176 & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) 177 IF ( SLAVE_NODE ) THEN 178 IROW = IWPOS 179 INDCOL = IWPOS + NBROWS_PACKET 180 ELSE 181 IROW = IWPOS 182 INDCOL = -1 183 END IF 184 IWPOS = IWPOS + LREQI 185 IF ( SLAVE_NODE ) THEN 186 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 187 & IW( INDCOL ), LROW, MPI_INTEGER, 188 & COMM, IERR ) 189 END IF 190 DO I = 1, NBROWS_PACKET 191 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 192 & IW( IROW + I - 1 ), 1, MPI_INTEGER, 193 & COMM, IERR ) 194 END DO 195 IF ( SLAVE_NODE ) THEN 196 IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN 197 NBPROCFILS(STEP(INODE))=NBPROCFILS(STEP(INODE))-NBROW 198#if ! defined(NO_XXNBPR) 199 IW(PTRIST(STEP(INODE))+XXNBPR) = 200 & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW 201#endif 202 ENDIF 203 IF ( KEEP(55) .eq. 0 ) THEN 204 CALL CMUMPS_ASM_SLAVE_TO_SLAVE_INIT 205 & (N, INODE, IW, LIW, A, LA, 206 & NBROW, LROW, 207 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, 208 & ITLOC, RHS_MUMPS, 209 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, 210 & KEEP,KEEP8, MYID ) 211 ELSE 212 CALL CMUMPS_ELT_ASM_S_2_S_INIT( 213 & NELT, FRTPTR, FRTELT, 214 & N, INODE, IW, LIW, A, LA, 215 & NBROW, LROW, 216 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, 217 & ITLOC, RHS_MUMPS, 218 & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, 219 & KEEP,KEEP8, MYID ) 220 ENDIF 221 DO I=1,NBROWS_PACKET 222 IF(KEEP(50).NE.0)THEN 223 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 224 & ROW_LENGTH, 225 & 1, 226 & MPI_INTEGER, 227 & COMM, IERR ) 228 ELSE 229 ROW_LENGTH=LROW 230 ENDIF 231 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 232 & A(POSCONTRIB), 233 & ROW_LENGTH, 234 & MPI_COMPLEX, 235 & COMM, IERR ) 236 CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, 237 & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), 238 & A(POSCONTRIB), 239 & OPASSW, OPELIW, STEP, PTRIST, PTRAST, 240 & ITLOC, RHS_MUMPS, 241 & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, 242 & ROW_LENGTH ) 243 ENDDO 244 CALL CMUMPS_ASM_SLAVE_TO_SLAVE_END 245 & (N, INODE, IW, LIW, 246 & NBROWS_PACKET, STEP, PTRIST, 247 & ITLOC, RHS_MUMPS,KEEP,KEEP8) 248 ELSE 249 DO I=1,NBROWS_PACKET 250 IF(KEEP(50).NE.0)THEN 251 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 252 & ROW_LENGTH, 253 & 1, 254 & MPI_INTEGER, 255 & COMM, IERR ) 256 ELSE 257 ROW_LENGTH=LROW 258 ENDIF 259 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 260 & A(POSCONTRIB), 261 & ROW_LENGTH, 262 & MPI_COMPLEX, 263 & COMM, IERR ) 264 CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, 265 & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), 266 & A(POSCONTRIB), PTLUST, PTRAST, 267 & STEP, PIMASTER, OPASSW, 268 & IWPOSCB, MYID, KEEP,KEEP8, 269 & IS_ofType5or6, ROW_LENGTH 270 &) 271 ENDDO 272 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN 273 IF (KEEP(219).NE.0) THEN 274 IF(KEEP(50) .EQ. 2) THEN 275 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 276 & NFS4FATHER, 277 & 1, 278 & MPI_INTEGER, 279 & COMM, IERR ) 280 IF(NFS4FATHER .GT. 0) THEN 281 CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) 282 IF (IERR .NE. 0) THEN 283 IERROR = BUF_LMAX_ARRAY 284 IFLAG = -13 285 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 286 RETURN 287 ENDIF 288 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 289 & BUF_MAX_ARRAY, 290 & NFS4FATHER, 291 & MPI_REAL, 292 & COMM, IERR ) 293 CALL CMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, 294 & ISON, NFS4FATHER, 295 & BUF_MAX_ARRAY, PTLUST, PTRAST, 296 & STEP, PIMASTER, OPASSW, 297 & IWPOSCB, MYID, KEEP,KEEP8) 298 ENDIF 299 ENDIF 300 ENDIF 301 ENDIF 302 IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN 303 DECR = 1 304 NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - DECR 305 NBPROCFILS(STEP(ISON)) = NBPROCFILS(STEP(ISON)) - DECR 306 ISTCHK = PIMASTER(STEP(ISON)) 307 SAME_PROC = ISTCHK .LT. IWPOSCB 308#if ! defined(NO_XXNBPR) 309 IW(PTLUST(STEP(INODE))+XXNBPR) = 310 & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR 311 IF (SAME_PROC) THEN 312 INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR 313 ELSE 314 INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR 315 ENDIF 316 IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR 317#endif 318#if ! defined(NO_XXNBPR) 319 IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN 320#else 321 IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN 322#endif 323 IF (SAME_PROC) THEN 324 CALL CMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, 325 & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) 326 ENDIF 327 IF (SAME_PROC) THEN 328 ISTCHK = PTRIST(STEP(ISON)) 329 PTRIST(STEP( ISON) ) = -99999999 330 ELSE 331 PIMASTER(STEP( ISON )) = -99999999 332 ENDIF 333 CALL CMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK, 334 & PAMASTER(STEP(ISON)), 335 & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, 336 & LA, KEEP,KEEP8, .FALSE. 337 & ) 338 ENDIF 339#if ! defined(NO_XXNBPR) 340 IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN 341#else 342 IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN 343#endif 344 CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, 345 & PROCNODE_STEPS, 346 & SLAVEF, KEEP(28), KEEP(76), KEEP(80), 347 & KEEP(47), STEP, INODE+N ) 348 IF (KEEP(47) .GE. 3) THEN 349 CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( 350 & IPOOL, LPOOL, 351 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 352 & MYID, STEP, N, ND, FILS ) 353 ENDIF 354 ENDIF 355 ENDIF 356 END IF 357 IWPOS = IWPOS - LREQI 358 LRLU = LRLU + LREQA 359 LRLUS = LRLUS + LREQA 360 KEEP8(70) = KEEP8(70) + LREQA 361 KEEP8(71) = KEEP8(71) + LREQA 362 POSFAC = POSFAC - LREQA 363 CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., 364 & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) 365 RETURN 366 END SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE2 367