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_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, 14 & TOT_CONT_TO_RECV, root, 15 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 16 & IWPOS, IWPOSCB, IPTRLU, 17 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 18 & PTLUST, PTRFAC, 19 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 20 & IFLAG, IERROR, COMM, COMM_LOAD, 21 & NBPROCFILS, 22 & IPOOL, LPOOL, LEAF, 23 & NBFIN, MYID, SLAVEF, 24 & 25 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 26 & FILS, PTRARW, PTRAIW, 27 & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) 28 USE SMUMPS_LOAD 29 USE SMUMPS_OOC 30 IMPLICIT NONE 31 INCLUDE 'mpif.h' 32 INCLUDE 'smumps_root.h' 33 TYPE (SMUMPS_ROOT_STRUC) :: root 34 INTEGER KEEP(500), ICNTL(40) 35 INTEGER(8) KEEP8(150) 36 REAL DKEEP(230) 37 INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV 38 INTEGER LBUFR, LBUFR_BYTES 39 INTEGER BUFR( LBUFR ) 40 INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC 41 INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) 42 INTEGER(8) :: PAMASTER(KEEP(28)) 43 INTEGER IWPOS, IWPOSCB 44 INTEGER N, LIW 45 INTEGER IW( LIW ) 46 REAL A( LA ) 47 INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) 48 INTEGER STEP(N), PIMASTER(KEEP(28)) 49 INTEGER COMP 50 INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) 51 INTEGER NBPROCFILS( KEEP(28) ), ND( KEEP(28) ) 52 INTEGER IFLAG, IERROR, COMM, COMM_LOAD 53 INTEGER LPOOL, LEAF 54 INTEGER IPOOL( LPOOL ) 55 INTEGER MYID, SLAVEF, NBFIN 56 DOUBLE PRECISION OPASSW, OPELIW 57 INTEGER ITLOC(N+KEEP(253)), FILS(N) 58 INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) 59 REAL :: RHS_MUMPS(KEEP(255)) 60 INTEGER INTARR(KEEP8(27)) 61 REAL DBLARR(KEEP8(26)) 62 INTEGER :: allocok 63 REAL, DIMENSION(:,:), POINTER :: TMP 64 INTEGER NEW_LOCAL_M, NEW_LOCAL_N 65 INTEGER OLD_LOCAL_M, OLD_LOCAL_N 66 INTEGER I, J 67 INTEGER LREQI, IROOT 68 INTEGER(8) :: LREQA 69 INTEGER POSHEAD, IPOS_SON,IERR 70 LOGICAL MASTER_OF_ROOT 71 REAL ZERO 72 PARAMETER( ZERO = 0.0E0 ) 73 INCLUDE 'mumps_headers.h' 74 INTEGER numroc, MUMPS_PROCNODE 75 EXTERNAL numroc, MUMPS_PROCNODE 76 IROOT = KEEP( 38 ) 77 root%TOT_ROOT_SIZE = TOT_ROOT_SIZE 78 MASTER_OF_ROOT = ( MYID .EQ. 79 & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), 80 & SLAVEF ) ) 81 NEW_LOCAL_M = numroc( TOT_ROOT_SIZE, root%MBLOCK, 82 & root%MYROW, 0, root%NPROW ) 83 NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) 84 NEW_LOCAL_N = numroc( TOT_ROOT_SIZE, root%NBLOCK, 85 & root%MYCOL, 0, root%NPCOL ) 86 IF ( PTRIST(STEP( IROOT )).GT.0) THEN 87 OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) 88 OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) 89 ELSE 90 OLD_LOCAL_N = 0 91 OLD_LOCAL_M = NEW_LOCAL_M 92 ENDIF 93 IF (KEEP(60) .NE. 0) THEN 94 IF (root%yes) THEN 95 IF ( NEW_LOCAL_M .NE. root%SCHUR_MLOC .OR. 96 & NEW_LOCAL_N .NE. root%SCHUR_NLOC ) THEN 97 WRITE(*,*) "Internal error 1 in SMUMPS_PROCESS_ROOT2SLAVE" 98 CALL MUMPS_ABORT() 99 ENDIF 100 ENDIF 101 PTLUST(STEP(IROOT)) = -4444 102 PTRFAC(STEP(IROOT)) = -4445_8 103 PTRIST(STEP(IROOT)) = 0 104 IF ( MASTER_OF_ROOT ) THEN 105 LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) 106 LREQA=0_8 107 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN 108 CALL SMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA, 109 & LRLU, IPTRLU, 110 & IWPOS, IWPOSCB, PTRIST, PTRAST, 111 & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, 112 & KEEP(IXSZ),COMP,DKEEP(97),MYID ) 113 IF ( LRLU .NE. LRLUS ) THEN 114 WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', 115 & LRLU, LRLUS 116 IFLAG = -9 117 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) 118 GOTO 700 119 END IF 120 ENDIF 121 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN 122 IFLAG = -8 123 IERROR = IWPOS + LREQI - 1 - IWPOSCB 124 GOTO 700 125 ENDIF 126 PTLUST(STEP(IROOT))= IWPOS 127 IWPOS = IWPOS + LREQI 128 POSHEAD = PTLUST( STEP(IROOT)) 129 IW( POSHEAD + XXI )=LREQI 130 CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) 131 IW( POSHEAD + XXS )=-9999 132 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 133 IW( POSHEAD +KEEP(IXSZ)) = 0 134 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 135 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 136 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) 137 IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 138 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE 139 ENDIF 140 GOTO 100 141 ENDIF 142 IF ( MASTER_OF_ROOT ) THEN 143 LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) 144 ELSE 145 LREQI = 6+KEEP(IXSZ) 146 END IF 147 LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) 148 IF ( LRLU . LT. LREQA .OR. 149 & IWPOS + LREQI - 1. GT. IWPOSCB )THEN 150 IF ( LRLUS .LT. LREQA ) THEN 151 IFLAG = -9 152 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) 153 GOTO 700 154 END IF 155 CALL SMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA, 156 & LRLU, IPTRLU, 157 & IWPOS, IWPOSCB, PTRIST, PTRAST, 158 & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, 159 & KEEP(IXSZ), COMP, DKEEP(97), MYID ) 160 IF ( LRLU .NE. LRLUS ) THEN 161 WRITE(*,*) 'PB2 compress root2slave:LRLU,LRLUS=', 162 & LRLU, LRLUS 163 IFLAG = -9 164 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) 165 GOTO 700 166 END IF 167 IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN 168 IFLAG = -8 169 IERROR = IWPOS + LREQI - 1 - IWPOSCB 170 GOTO 700 171 END IF 172 END IF 173 PTLUST(STEP( IROOT )) = IWPOS 174 IWPOS = IWPOS + LREQI 175 IF (LREQA.EQ.0_8) THEN 176 PTRAST (STEP(IROOT)) = POSFAC 177 PTRFAC (STEP(IROOT)) = POSFAC 178 ELSE 179 PTRAST (STEP(IROOT)) = POSFAC 180 PTRFAC (STEP(IROOT)) = POSFAC 181 ENDIF 182 POSFAC = POSFAC + LREQA 183 LRLU = LRLU - LREQA 184 LRLUS = LRLUS - LREQA 185 KEEP8(67) = min(KEEP8(67), LRLUS) 186 KEEP8(70) = KEEP8(70) - LREQA 187 KEEP8(68) = min(KEEP8(70), KEEP8(68)) 188 KEEP8(71) = KEEP8(71) - LREQA 189 KEEP8(69) = min(KEEP8(71), KEEP8(69)) 190 CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., 191 & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) 192 POSHEAD = PTLUST( STEP(IROOT)) 193 IW( POSHEAD + XXI ) = LREQI 194 CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) 195 IW( POSHEAD + XXS ) = S_NOTFREE 196 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 197 IW( POSHEAD + KEEP(IXSZ) ) = 0 198 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N 199 IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M 200 IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) 201 IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 202 IF ( MASTER_OF_ROOT ) THEN 203 IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE 204 ELSE 205 IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 206 ENDIF 207 IF ( PTRIST(STEP( IROOT )) .LE. 0 ) THEN 208 PTRIST(STEP( IROOT )) = 0 209 PAMASTER(STEP( IROOT )) = 0_8 210 IF (LREQA.GT.0_8) A(PTRAST(STEP(IROOT)): 211 & PTRAST(STEP(IROOT))+LREQA-1_8) = ZERO 212 ELSE 213 OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) 214 OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) 215 IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN 216 IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) 217 & THEN 218 write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', 219 & OLD_LOCAL_M, OLD_LOCAL_N 220 CALL MUMPS_ABORT() 221 END IF 222 CALL SMUMPS_COPYI8SIZE(LREQA, 223 & A( PAMASTER(STEP(IROOT)) ), 224 & A( PTRAST (STEP(IROOT)) ) ) 225 ELSE 226 CALL SMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), 227 & NEW_LOCAL_M, 228 & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, 229 & OLD_LOCAL_N ) 230 END IF 231 IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN 232 IPOS_SON= PTRIST( STEP(IROOT)) 233 CALL SMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, IPOS_SON, 234 & PAMASTER(STEP(IROOT)), 235 & IW, LIW, LRLU, LRLUS, IPTRLU, 236 & IWPOSCB, LA, KEEP,KEEP8, .FALSE. 237 & ) 238 PTRIST(STEP( IROOT )) = 0 239 PAMASTER(STEP( IROOT )) = 0_8 240 END IF 241 END IF 242 IF (NEW_LOCAL_M.GT.OLD_LOCAL_M) THEN 243 TMP => root%RHS_ROOT 244 NULLIFY(root%RHS_ROOT) 245 ALLOCATE (root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), 246 & stat=allocok) 247 IF ( allocok.GT.0) THEN 248 IFLAG=-13 249 IERROR = NEW_LOCAL_M*root%RHS_NLOC 250 GOTO 700 251 ENDIF 252 DO J = 1, root%RHS_NLOC 253 DO I = 1, OLD_LOCAL_M 254 root%RHS_ROOT(I,J)=TMP(I,J) 255 ENDDO 256 DO I = OLD_LOCAL_M+1, NEW_LOCAL_M 257 root%RHS_ROOT(I,J) = ZERO 258 ENDDO 259 ENDDO 260 DEALLOCATE(TMP) 261 NULLIFY(TMP) 262 ENDIF 263 100 CONTINUE 264 NBPROCFILS(STEP(IROOT))=NBPROCFILS(STEP(IROOT)) + TOT_CONT_TO_RECV 265#if ! defined(NO_XXNBPR) 266 KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV 267#endif 268#if ! defined(NO_XXNBPR) 269 CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121)) 270 IF ( KEEP(121) .eq. 0 ) THEN 271#else 272 IF ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN 273#endif 274 IF (KEEP(201).EQ.1) THEN 275 CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) 276 ELSE IF (KEEP(201).EQ.2) THEN 277 CALL SMUMPS_FORCE_WRITE_BUF(IERR) 278 ENDIF 279 CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, 280 & SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47), 281 & STEP, IROOT + N ) 282 IF (KEEP(47) .GE. 3) THEN 283 CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( 284 & IPOOL, LPOOL, 285 & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, 286 & MYID, STEP, N, ND, FILS ) 287 ENDIF 288 END IF 289 RETURN 290 700 CONTINUE 291 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 292 RETURN 293 END SUBROUTINE SMUMPS_PROCESS_ROOT2SLAVE 294 SUBROUTINE SMUMPS_COPY_ROOT 295 &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) 296 INTEGER M_NEW, N_NEW, M_OLD, N_OLD 297 REAL NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) 298 INTEGER J 299 REAL ZERO 300 PARAMETER( ZERO = 0.0E0 ) 301 DO J = 1, N_OLD 302 NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) 303 NEW( M_OLD + 1: M_NEW, J ) = ZERO 304 END DO 305 NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO 306 RETURN 307 END SUBROUTINE SMUMPS_COPY_ROOT 308