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 ZMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, 14 & LBUFR_BYTES, 15 & root, N, IW, LIW, A, LA, 16 & NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB, 17 & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, 18 & COMP, LRLUS, IPOOL, LPOOL, LEAF, 19 & FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR, 20 & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, 21 & ITLOC, RHS_MUMPS, 22 & ND,PROCNODE_STEPS,SLAVEF ) 23 USE ZMUMPS_LOAD 24 USE ZMUMPS_OOC 25 IMPLICIT NONE 26 INCLUDE 'zmumps_root.h' 27 TYPE (ZMUMPS_ROOT_STRUC ) :: root 28 INTEGER :: KEEP( 500 ) 29 INTEGER(8) :: KEEP8(150) 30 DOUBLE PRECISION :: DKEEP(230) 31 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS 32 INTEGER(8) :: PAMASTER(KEEP(28)) 33 INTEGER(8) :: PTRAST(KEEP(28)) 34 INTEGER(8) :: PTRFAC(KEEP(28)) 35 INTEGER LBUFR, LBUFR_BYTES, N, LIW, 36 & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, 37 & IERROR 38 INTEGER LPOOL, LEAF 39 INTEGER IPOOL( LEAF ) 40 INTEGER PTRIST(KEEP(28)) 41 INTEGER PTLUST(KEEP(28)) 42 INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) 43 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 44 INTEGER BUFR( LBUFR_BYTES ), NBPROCFILS( KEEP(28) ) 45 INTEGER IW( LIW ) 46 INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF 47 COMPLEX(kind=8) A( LA ) 48 INTEGER MYID 49 INTEGER FILS( N ) 50 INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N ) 51 INTEGER INTARR(KEEP8(27)) 52 COMPLEX(kind=8) DBLARR(KEEP8(26)) 53 INCLUDE 'mpif.h' 54 INTEGER IERR 55 EXTERNAL MUMPS_PROCNODE 56 INTEGER MUMPS_PROCNODE 57 INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI 58 INTEGER(8) :: LREQA, POS_ROOT 59 INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF 60 INTEGER NSUPCOL_EFF 61 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET 62 INTEGER NSUPROW, NSUPCOL, BBPCBP 63 INCLUDE 'mumps_headers.h' 64 POSITION = 0 65 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 66 & ISON, 1, MPI_INTEGER, COMM, IERR ) 67 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 68 & NSUBSET_ROW, 1, MPI_INTEGER, COMM, IERR ) 69 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 70 & NSUPROW, 1, MPI_INTEGER, COMM, IERR ) 71 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 72 & NSUBSET_COL, 1, MPI_INTEGER, COMM, IERR ) 73 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 74 & NSUPCOL, 1, MPI_INTEGER, COMM, IERR ) 75 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 76 & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, 77 & COMM, IERR ) 78 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 79 & NBROWS_PACKET, 1, MPI_INTEGER, 80 & COMM, IERR ) 81 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 82 & BBPCBP, 1, MPI_INTEGER, 83 & COMM, IERR ) 84 IF (BBPCBP .EQ. 1) THEN 85 NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL 86 NSUPCOL_EFF = 0 87 ELSE 88 NSUBSET_COL_EFF = NSUBSET_COL 89 NSUPCOL_EFF = NSUPCOL 90 ENDIF 91 IROOT = KEEP( 38 ) 92 IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR. 93 & PTLUST( STEP(IROOT)) .NE. 0 ) THEN 94 IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW 95 & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. 96 & NSUBSET_COL_EFF .EQ. 0)THEN 97 NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1 98#if ! defined(NO_XXNBPR) 99 KEEP(121) = KEEP(121) - 1 100 CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)),KEEP(121)) 101 IF ( KEEP(121) .eq. 0 ) THEN 102#else 103 IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN 104#endif 105 IF (KEEP(201).EQ.1) THEN 106 CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) 107 ELSEIF (KEEP(201).EQ.2) THEN 108 CALL ZMUMPS_FORCE_WRITE_BUF(IERR) 109 ENDIF 110 CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, 111 & PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76), 112 & KEEP(80), KEEP(47), 113 & STEP, IROOT + N) 114 IF (KEEP(47) .GE. 3) THEN 115 CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( 116 & IPOOL, LPOOL, 117 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 118 & MYID, STEP, N, ND, FILS ) 119 ENDIF 120 ENDIF 121 ENDIF 122 ELSE 123 IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. 124 & NSUBSET_ROW - NSUPROW .OR. 125 & NSUBSET_ROW - NSUPROW.EQ.0 .OR. 126 & NSUBSET_COL_EFF .EQ. 0)THEN 127 NBPROCFILS(STEP( IROOT ) ) = -1 128#if ! defined(NO_XXNBPR) 129 KEEP(121)=-1 130#endif 131 ENDIF 132 IF (KEEP(60) == 0) THEN 133 CALL ZMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, 134 & IW, LIW, A, LA, 135 & FILS, MYID, 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 ELSE 142 PTRIST(STEP(IROOT)) = -55555 143 ENDIF 144 END IF 145 IF (KEEP(60) .EQ.0) THEN 146 IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN 147 IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN 148 LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) 149 LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) 150 POS_ROOT = PAMASTER(STEP( IROOT )) 151 ELSE 152 LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) 153 LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) 154 POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ 155 & KEEP(IXSZ))) 156 END IF 157 ENDIF 158 ELSE 159 LOCAL_M = root%SCHUR_LLD 160 LOCAL_N = root%SCHUR_NLOC 161 ENDIF 162 IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. 163 & (min(NSUPROW, NSUPCOL) .GT. 0) 164 & ) THEN 165 LREQI = NSUPROW+NSUPCOL 166 LREQA = int(NSUPROW,8) * int(NSUPCOL,8) 167 IF ( (LREQA.NE.0_8) .AND. 168 & (PTRIST(STEP(IROOT)).LT.0).AND. 169 & KEEP(60)==0) THEN 170 WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3' 171 CALL MUMPS_ABORT() 172 ENDIF 173 CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., 174 & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, 175 & LRLU, IPTRLU, IWPOS, IWPOSCB, PTRIST, 176 & PTRAST, STEP, PIMASTER, PAMASTER, 177 & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., 178 & COMP, LRLUS, IFLAG, IERROR 179 & ) 180 IF ( IFLAG .LT. 0 ) RETURN 181 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 182 & IW( IWPOSCB + 1 ), LREQI, 183 & MPI_INTEGER, COMM, IERR ) 184 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 185 & A( IPTRLU + 1_8 ), int(LREQA), 186 & MPI_DOUBLE_COMPLEX, COMM, IERR ) 187 CALL ZMUMPS_ASS_ROOT( NSUPROW, NSUPCOL, 188 & IW( IWPOSCB + 1 ), 189 & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, 190 & A( IPTRLU + 1_8 ), 191 & A( 1 ), 192 & LOCAL_M, LOCAL_N, 193 & root%RHS_ROOT(1,1), root%RHS_NLOC, 194 & 1) 195 IWPOSCB = IWPOSCB + LREQI 196 IPTRLU = IPTRLU + LREQA 197 LRLU = LRLU + LREQA 198 LRLUS = LRLUS + LREQA 199 KEEP8(70) = KEEP8(70) + LREQA 200 KEEP8(71) = KEEP8(71) + LREQA 201 CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., 202 & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) 203 ENDIF 204 LREQI = NBROWS_PACKET + NSUBSET_COL_EFF 205 LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) 206 IF ( (LREQA.NE.0_8) .AND. 207 & (PTRIST(STEP(IROOT)).LT.0).AND. 208 & KEEP(60)==0) THEN 209 WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3' 210 CALL MUMPS_ABORT() 211 ENDIF 212 IF (LREQA.NE.0_8) THEN 213 CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., 214 & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, 215 & LRLU, IPTRLU, IWPOS, IWPOSCB, PTRIST, 216 & PTRAST, STEP, PIMASTER, PAMASTER, 217 & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., 218 & COMP, LRLUS, IFLAG, IERROR 219 & ) 220 IF ( IFLAG .LT. 0 ) RETURN 221 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 222 & IW( IWPOSCB + 1 ), LREQI, 223 & MPI_INTEGER, COMM, IERR ) 224 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, 225 & A( IPTRLU + 1_8 ), int(LREQA), 226 & MPI_DOUBLE_COMPLEX, COMM, IERR ) 227 IF (KEEP(60).EQ.0) THEN 228 CALL ZMUMPS_ASS_ROOT( NBROWS_PACKET, NSUBSET_COL_EFF, 229 & IW( IWPOSCB + 1 ), 230 & IW( IWPOSCB + NBROWS_PACKET + 1 ), 231 & NSUPCOL_EFF, 232 & A( IPTRLU + 1_8 ), 233 & A( POS_ROOT ), LOCAL_M, LOCAL_N, 234 & root%RHS_ROOT(1,1), root%RHS_NLOC, 235 & 0) 236 ELSE 237 CALL ZMUMPS_ASS_ROOT( 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(70) = KEEP8(70) + LREQA 252 KEEP8(71) = KEEP8(71) + LREQA 253 CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., 254 & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) 255 ENDIF 256 RETURN 257 END SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE3 258