src/smpi/colls/reduce/reduce-ompi.cpp

   1 /* Copyright (c) 2013-2017. The SimGrid Team.
   2  * All rights reserved.                                                     */
   3
   4 /* This program is free software; you can redistribute it and/or modify it
   5  * under the terms of the license (GNU LGPL) which comes with this package. */
   6
   7 /*
   8  * Copyright (c) 2004-2005 The Trustees of Indiana University and Indiana
   9  *                         University Research and Technology
  10  *                         Corporation.  All rights reserved.
  11  * Copyright (c) 2004-2009 The University of Tennessee and The University
  12  *                         of Tennessee Research Foundation.  All rights
  13  *                         reserved.
  14  * Copyright (c) 2004-2005 High Performance Computing Center Stuttgart,
  15  *                         University of Stuttgart.  All rights reserved.
  16  * Copyright (c) 2004-2005 The Regents of the University of California.
  17  *                         All rights reserved.
  18  *
  19  * Additional copyrights may follow
  20  */
  21
  22 #include "../colls_private.h"
  23 #include "../coll_tuned_topo.h"
  24
  25 namespace simgrid{
  26 namespace smpi{
  27
  28 int smpi_coll_tuned_ompi_reduce_generic( void* sendbuf, void* recvbuf, int original_count,
  29                                     MPI_Datatype datatype, MPI_Op  op,
  30                                     int root, MPI_Comm comm,
  31                                     ompi_coll_tree_t* tree, int count_by_segment,
  32                                     int max_outstanding_reqs );
  33 /**
  34  * This is a generic implementation of the reduce protocol. It used the tree
  35  * provided as an argument and execute all operations using a segment of
  36  * count times a datatype.
  37  * For the last communication it will update the count in order to limit
  38  * the number of datatype to the original count (original_count)
  39  *
  40  * Note that for non-commutative operations we cannot save memory copy
  41  * for the first block: thus we must copy sendbuf to accumbuf on intermediate
  42  * to keep the optimized loop happy.
  43  */
  44 int smpi_coll_tuned_ompi_reduce_generic( void* sendbuf, void* recvbuf, int original_count,
  45                                     MPI_Datatype datatype, MPI_Op  op,
  46                                     int root, MPI_Comm comm,
  47                                     ompi_coll_tree_t* tree, int count_by_segment,
  48                                     int max_outstanding_reqs )
  49 {
  50     char *inbuf[2] = {NULL, NULL}, *inbuf_free[2] = {NULL, NULL};
  51     char *accumbuf = NULL, *accumbuf_free = NULL;
  52     char *local_op_buffer = NULL, *sendtmpbuf = NULL;
  53     ptrdiff_t extent, lower_bound, segment_increment;
  54     MPI_Request  reqs[2] = {MPI_REQUEST_NULL, MPI_REQUEST_NULL};
  55     int num_segments, line, ret, segindex, i, rank;
  56     int recvcount, prevcount, inbi;
  57
  58     /**
  59      * Determine number of segments and number of elements
  60      * sent per operation
  61      */
  62     datatype->extent(&lower_bound, &extent);
  63     num_segments = (original_count + count_by_segment - 1) / count_by_segment;
  64     segment_increment = count_by_segment * extent;
  65
  66     sendtmpbuf = (char*) sendbuf;
  67     if( sendbuf == MPI_IN_PLACE ) {
  68         sendtmpbuf = (char *)recvbuf;
  69     }
  70
  71     XBT_DEBUG( "coll:tuned:reduce_generic count %d, msg size %ld, segsize %ld, max_requests %d", original_count, (unsigned long)(num_segments * segment_increment), (unsigned long)segment_increment, max_outstanding_reqs);
  72
  73     rank = comm->rank();
  74
  75     /* non-leaf nodes - wait for children to send me data & forward up
  76        (if needed) */
  77     if( tree->tree_nextsize > 0 ) {
  78         ptrdiff_t true_extent, real_segment_size;
  79         true_extent=datatype->get_extent();
  80
  81         /* handle non existant recv buffer (i.e. its NULL) and
  82            protect the recv buffer on non-root nodes */
  83         accumbuf = (char*)recvbuf;
  84         if( (NULL == accumbuf) || (root != rank) ) {
  85             /* Allocate temporary accumulator buffer. */
  86             accumbuf_free = (char*)smpi_get_tmp_sendbuffer(true_extent +
  87                                           (original_count - 1) * extent);
  88             if (accumbuf_free == NULL) {
  89                 line = __LINE__; ret = -1; goto error_hndl;
  90             }
  91             accumbuf = accumbuf_free - lower_bound;
  92         }
  93
  94         /* If this is a non-commutative operation we must copy
  95            sendbuf to the accumbuf, in order to simplfy the loops */
  96         if ((op != MPI_OP_NULL && not op->is_commutative())) {
  97           Datatype::copy((char*)sendtmpbuf, original_count, datatype, (char*)accumbuf, original_count, datatype);
  98         }
  99         /* Allocate two buffers for incoming segments */
 100         real_segment_size = true_extent + (count_by_segment - 1) * extent;
 101         inbuf_free[0] = (char*) smpi_get_tmp_recvbuffer(real_segment_size);
 102         if( inbuf_free[0] == NULL ) {
 103             line = __LINE__; ret = -1; goto error_hndl;
 104         }
 105         inbuf[0] = inbuf_free[0] - lower_bound;
 106         /* if there is chance to overlap communication -
 107            allocate second buffer */
 108         if( (num_segments > 1) || (tree->tree_nextsize > 1) ) {
 109             inbuf_free[1] = (char*) smpi_get_tmp_recvbuffer(real_segment_size);
 110             if( inbuf_free[1] == NULL ) {
 111                 line = __LINE__; ret = -1; goto error_hndl;
 112             }
 113             inbuf[1] = inbuf_free[1] - lower_bound;
 114         }
 115
 116         /* reset input buffer index and receive count */
 117         inbi = 0;
 118         recvcount = 0;
 119         /* for each segment */
 120         for( segindex = 0; segindex <= num_segments; segindex++ ) {
 121             prevcount = recvcount;
 122             /* recvcount - number of elements in current segment */
 123             recvcount = count_by_segment;
 124             if( segindex == (num_segments-1) )
 125                 recvcount = original_count - count_by_segment * segindex;
 126
 127             /* for each child */
 128             for( i = 0; i < tree->tree_nextsize; i++ ) {
 129                 /**
 130                  * We try to overlap communication:
 131                  * either with next segment or with the next child
 132                  */
 133                 /* post irecv for current segindex on current child */
 134                 if( segindex < num_segments ) {
 135                     void* local_recvbuf = inbuf[inbi];
 136                     if( 0 == i ) {
 137                         /* for the first step (1st child per segment) and
 138                          * commutative operations we might be able to irecv
 139                          * directly into the accumulate buffer so that we can
 140                          * reduce(op) this with our sendbuf in one step as
 141                          * ompi_op_reduce only has two buffer pointers,
 142                          * this avoids an extra memory copy.
 143                          *
 144                          * BUT if the operation is non-commutative or
 145                          * we are root and are USING MPI_IN_PLACE this is wrong!
 146                          */
 147                         if(  (op==MPI_OP_NULL || op->is_commutative()) &&
 148                             !((MPI_IN_PLACE == sendbuf) && (rank == tree->tree_root)) ) {
 149                             local_recvbuf = accumbuf + segindex * segment_increment;
 150                         }
 151                     }
 152
 153                     reqs[inbi]=Request::irecv(local_recvbuf, recvcount, datatype,
 154                                              tree->tree_next[i],
 155                                              COLL_TAG_REDUCE, comm
 156                                              );
 157                 }
 158                 /* wait for previous req to complete, if any.
 159                    if there are no requests reqs[inbi ^1] will be
 160                    MPI_REQUEST_NULL. */
 161                 /* wait on data from last child for previous segment */
 162                 Request::waitall( 1, &reqs[inbi ^ 1],
 163                                              MPI_STATUSES_IGNORE );
 164                 local_op_buffer = inbuf[inbi ^ 1];
 165                 if( i > 0 ) {
 166                     /* our first operation is to combine our own [sendbuf] data
 167                      * with the data we recvd from down stream (but only
 168                      * the operation is commutative and if we are not root and
 169                      * not using MPI_IN_PLACE)
 170                      */
 171                     if( 1 == i ) {
 172                         if( (op==MPI_OP_NULL || op->is_commutative())&&
 173                             !((MPI_IN_PLACE == sendbuf) && (rank == tree->tree_root)) ) {
 174                             local_op_buffer = sendtmpbuf + segindex * segment_increment;
 175                         }
 176                     }
 177                     /* apply operation */
 178                     if(op!=MPI_OP_NULL) op->apply( local_op_buffer,
 179                                    accumbuf + segindex * segment_increment,
 180                                    &recvcount, datatype );
 181                 } else if ( segindex > 0 ) {
 182                     void* accumulator = accumbuf + (segindex-1) * segment_increment;
 183                     if( tree->tree_nextsize <= 1 ) {
 184                         if(  (op==MPI_OP_NULL || op->is_commutative()) &&
 185                             !((MPI_IN_PLACE == sendbuf) && (rank == tree->tree_root)) ) {
 186                             local_op_buffer = sendtmpbuf + (segindex-1) * segment_increment;
 187                         }
 188                     }
 189                     if(op!=MPI_OP_NULL) op->apply( local_op_buffer, accumulator, &prevcount,
 190                                    datatype );
 191
 192                     /* all reduced on available data this step (i) complete,
 193                      * pass to the next process unless you are the root.
 194                      */
 195                     if (rank != tree->tree_root) {
 196                         /* send combined/accumulated data to parent */
 197                         Request::send( accumulator, prevcount,
 198                                                   datatype, tree->tree_prev,
 199                                                   COLL_TAG_REDUCE,
 200                                                   comm);
 201                     }
 202
 203                     /* we stop when segindex = number of segments
 204                        (i.e. we do num_segment+1 steps for pipelining */
 205                     if (segindex == num_segments) break;
 206                 }
 207
 208                 /* update input buffer index */
 209                 inbi = inbi ^ 1;
 210             } /* end of for each child */
 211         } /* end of for each segment */
 212
 213         /* clean up */
 214         smpi_free_tmp_buffer(inbuf_free[0]);
 215         smpi_free_tmp_buffer(inbuf_free[1]);
 216         smpi_free_tmp_buffer(accumbuf_free);
 217     }
 218
 219     /* leaf nodes
 220        Depending on the value of max_outstanding_reqs and
 221        the number of segments we have two options:
 222        - send all segments using blocking send to the parent, or
 223        - avoid overflooding the parent nodes by limiting the number of
 224        outstanding requests to max_oustanding_reqs.
 225        TODO/POSSIBLE IMPROVEMENT: If there is a way to determine the eager size
 226        for the current communication, synchronization should be used only
 227        when the message/segment size is smaller than the eager size.
 228     */
 229     else {
 230
 231         /* If the number of segments is less than a maximum number of oustanding
 232            requests or there is no limit on the maximum number of outstanding
 233            requests, we send data to the parent using blocking send */
 234         if ((0 == max_outstanding_reqs) ||
 235             (num_segments <= max_outstanding_reqs)) {
 236
 237             segindex = 0;
 238             while ( original_count > 0) {
 239                 if (original_count < count_by_segment) {
 240                     count_by_segment = original_count;
 241                 }
 242                 Request::send((char*)sendbuf +
 243                                          segindex * segment_increment,
 244                                          count_by_segment, datatype,
 245                                          tree->tree_prev,
 246                                          COLL_TAG_REDUCE,
 247                                          comm) ;
 248                 segindex++;
 249                 original_count -= count_by_segment;
 250             }
 251         }
 252
 253         /* Otherwise, introduce flow control:
 254            - post max_outstanding_reqs non-blocking synchronous send,
 255            - for remaining segments
 256            - wait for a ssend to complete, and post the next one.
 257            - wait for all outstanding sends to complete.
 258         */
 259         else {
 260
 261             int creq = 0;
 262             MPI_Request* sreq = NULL;
 263
 264             sreq = (MPI_Request*) calloc( max_outstanding_reqs,
 265                                               sizeof(MPI_Request ) );
 266             if (NULL == sreq) { line = __LINE__; ret = -1; goto error_hndl; }
 267
 268             /* post first group of requests */
 269             for (segindex = 0; segindex < max_outstanding_reqs; segindex++) {
 270                 sreq[segindex]=Request::isend((char*)sendbuf +
 271                                           segindex * segment_increment,
 272                                           count_by_segment, datatype,
 273                                           tree->tree_prev,
 274                                           COLL_TAG_REDUCE,
 275                                           comm);
 276                 original_count -= count_by_segment;
 277             }
 278
 279             creq = 0;
 280             while ( original_count > 0 ) {
 281                 /* wait on a posted request to complete */
 282                 Request::wait(&sreq[creq], MPI_STATUS_IGNORE);
 283                 sreq[creq] = MPI_REQUEST_NULL;
 284
 285                 if( original_count < count_by_segment ) {
 286                     count_by_segment = original_count;
 287                 }
 288                 sreq[creq]=Request::isend((char*)sendbuf +
 289                                           segindex * segment_increment,
 290                                           count_by_segment, datatype,
 291                                           tree->tree_prev,
 292                                           COLL_TAG_REDUCE,
 293                                           comm );
 294                 creq = (creq + 1) % max_outstanding_reqs;
 295                 segindex++;
 296                 original_count -= count_by_segment;
 297             }
 298
 299             /* Wait on the remaining request to complete */
 300             Request::waitall( max_outstanding_reqs, sreq,
 301                                          MPI_STATUSES_IGNORE );
 302
 303             /* free requests */
 304             free(sreq);
 305         }
 306     }
 307     free(tree);
 308     return MPI_SUCCESS;
 309
 310  error_hndl:  /* error handler */
 311     XBT_DEBUG("ERROR_HNDL: node %d file %s line %d error %d\n",
 312                    rank, __FILE__, line, ret );
 313     if( inbuf_free[0] != NULL ) free(inbuf_free[0]);
 314     if( inbuf_free[1] != NULL ) free(inbuf_free[1]);
 315     if( accumbuf_free != NULL ) free(accumbuf);
 316     return ret;
 317 }
 318
 319 /* Attention: this version of the reduce operations does not
 320    work for:
 321    - non-commutative operations
 322    - segment sizes which are not multiplies of the extent of the datatype
 323      meaning that at least one datatype must fit in the segment !
 324 */
 325
 326
 327 int Coll_reduce_ompi_chain::reduce( void *sendbuf, void *recvbuf, int count,
 328                                         MPI_Datatype datatype,
 329                                         MPI_Op  op, int root,
 330                                         MPI_Comm  comm
 331                                         )
 332 {
 333     uint32_t segsize=64*1024;
 334     int segcount = count;
 335     size_t typelng;
 336     int fanout = comm->size()/2;
 337
 338     XBT_DEBUG("coll:tuned:reduce_intra_chain rank %d fo %d ss %5d", comm->rank(), fanout, segsize);
 339
 340     /**
 341      * Determine number of segments and number of elements
 342      * sent per operation
 343      */
 344     typelng = datatype->size();
 345
 346     COLL_TUNED_COMPUTED_SEGCOUNT( segsize, typelng, segcount );
 347
 348     return smpi_coll_tuned_ompi_reduce_generic( sendbuf, recvbuf, count, datatype,
 349                                            op, root, comm,
 350                                            ompi_coll_tuned_topo_build_chain(fanout, comm, root),
 351                                            segcount, 0 );
 352 }
 353
 354
 355 int Coll_reduce_ompi_pipeline::reduce( void *sendbuf, void *recvbuf,
 356                                            int count, MPI_Datatype datatype,
 357                                            MPI_Op  op, int root,
 358                                            MPI_Comm  comm  )
 359 {
 360
 361     uint32_t segsize;
 362     int segcount = count;
 363     size_t typelng;
 364 //    COLL_TUNED_UPDATE_PIPELINE( comm, tuned_module, root );
 365
 366     /**
 367      * Determine number of segments and number of elements
 368      * sent per operation
 369      */
 370     const double a2 =  0.0410 / 1024.0; /* [1/B] */
 371     const double b2 =  9.7128;
 372     const double a4 =  0.0033 / 1024.0; /* [1/B] */
 373     const double b4 =  1.6761;
 374     typelng= datatype->size();
 375     int communicator_size = comm->size();
 376     size_t message_size = typelng * count;
 377
 378     if (communicator_size > (a2 * message_size + b2)) {
 379         // Pipeline_1K
 380         segsize = 1024;
 381     }else if (communicator_size > (a4 * message_size + b4)) {
 382         // Pipeline_32K
 383         segsize = 32*1024;
 384     } else {
 385         // Pipeline_64K
 386         segsize = 64*1024;
 387     }
 388
 389     XBT_DEBUG("coll:tuned:reduce_intra_pipeline rank %d ss %5d",
 390                  comm->rank(), segsize);
 391
 392     COLL_TUNED_COMPUTED_SEGCOUNT( segsize, typelng, segcount );
 393
 394     return smpi_coll_tuned_ompi_reduce_generic( sendbuf, recvbuf, count, datatype,
 395                                            op, root, comm,
 396                                            ompi_coll_tuned_topo_build_chain( 1, comm, root),
 397                                            segcount, 0);
 398 }
 399
 400 int Coll_reduce_ompi_binary::reduce( void *sendbuf, void *recvbuf,
 401                                          int count, MPI_Datatype datatype,
 402                                          MPI_Op  op, int root,
 403                                          MPI_Comm  comm)
 404 {
 405     uint32_t segsize;
 406     int segcount = count;
 407     size_t typelng;
 408
 409
 410
 411     /**
 412      * Determine number of segments and number of elements
 413      * sent per operation
 414      */
 415     typelng=datatype->size();
 416
 417         // Binary_32K
 418     segsize = 32*1024;
 419
 420     XBT_DEBUG("coll:tuned:reduce_intra_binary rank %d ss %5d",
 421                  comm->rank(), segsize);
 422
 423     COLL_TUNED_COMPUTED_SEGCOUNT( segsize, typelng, segcount );
 424
 425     return smpi_coll_tuned_ompi_reduce_generic( sendbuf, recvbuf, count, datatype,
 426                                            op, root, comm,
 427                                            ompi_coll_tuned_topo_build_tree(2, comm, root),
 428                                            segcount, 0);
 429 }
 430
 431 int Coll_reduce_ompi_binomial::reduce( void *sendbuf, void *recvbuf,
 432                                            int count, MPI_Datatype datatype,
 433                                            MPI_Op  op, int root,
 434                                            MPI_Comm  comm)
 435 {
 436
 437     uint32_t segsize=0;
 438     int segcount = count;
 439     size_t typelng;
 440
 441     const double a1 =  0.6016 / 1024.0; /* [1/B] */
 442     const double b1 =  1.3496;
 443
 444 //    COLL_TUNED_UPDATE_IN_ORDER_BMTREE( comm, tuned_module, root );
 445
 446     /**
 447      * Determine number of segments and number of elements
 448      * sent per operation
 449      */
 450     typelng= datatype->size();
 451     int communicator_size = comm->size();
 452     size_t message_size = typelng * count;
 453     if (((communicator_size < 8) && (message_size < 20480)) ||
 454                (message_size < 2048) || (count <= 1)) {
 455         /* Binomial_0K */
 456         segsize = 0;
 457     } else if (communicator_size > (a1 * message_size + b1)) {
 458         // Binomial_1K
 459         segsize = 1024;
 460     }
 461
 462     XBT_DEBUG("coll:tuned:reduce_intra_binomial rank %d ss %5d",
 463                  comm->rank(), segsize);
 464     COLL_TUNED_COMPUTED_SEGCOUNT( segsize, typelng, segcount );
 465
 466     return smpi_coll_tuned_ompi_reduce_generic( sendbuf, recvbuf, count, datatype,
 467                                            op, root, comm,
 468                                            ompi_coll_tuned_topo_build_in_order_bmtree(comm, root),
 469                                            segcount, 0);
 470 }
 471
 472 /*
 473  * reduce_intra_in_order_binary
 474  *
 475  * Function:      Logarithmic reduce operation for non-commutative operations.
 476  * Acecpts:       same as MPI_Reduce()
 477  * Returns:       MPI_SUCCESS or error code
 478  */
 479 int Coll_reduce_ompi_in_order_binary::reduce( void *sendbuf, void *recvbuf,
 480                                                   int count,
 481                                                   MPI_Datatype datatype,
 482                                                   MPI_Op  op, int root,
 483                                                   MPI_Comm  comm)
 484 {
 485     uint32_t segsize=0;
 486     int ret;
 487     int rank, size, io_root;
 488     int segcount = count;
 489     void *use_this_sendbuf = NULL, *use_this_recvbuf = NULL;
 490     size_t typelng;
 491
 492     rank = comm->rank();
 493     size = comm->size();
 494     XBT_DEBUG("coll:tuned:reduce_intra_in_order_binary rank %d ss %5d",
 495                  rank, segsize);
 496
 497     /**
 498      * Determine number of segments and number of elements
 499      * sent per operation
 500      */
 501     typelng=datatype->size();
 502     COLL_TUNED_COMPUTED_SEGCOUNT( segsize, typelng, segcount );
 503
 504     /* An in-order binary tree must use root (size-1) to preserve the order of
 505        operations.  Thus, if root is not rank (size - 1), then we must handle
 506        1. MPI_IN_PLACE option on real root, and
 507        2. we must allocate temporary recvbuf on rank (size - 1).
 508        Note that generic function must be careful not to switch order of
 509        operations for non-commutative ops.
 510     */
 511     io_root = size - 1;
 512     use_this_sendbuf = sendbuf;
 513     use_this_recvbuf = recvbuf;
 514     if (io_root != root) {
 515         ptrdiff_t text, ext;
 516         char *tmpbuf = NULL;
 517
 518         ext=datatype->get_extent();
 519         text=datatype->get_extent();
 520
 521         if ((root == rank) && (MPI_IN_PLACE == sendbuf)) {
 522             tmpbuf = (char *) smpi_get_tmp_sendbuffer(text + (count - 1) * ext);
 523             if (NULL == tmpbuf) {
 524                 return MPI_ERR_INTERN;
 525             }
 526             Datatype::copy (
 527                                                 (char*)recvbuf, count, datatype,
 528                                                 (char*)tmpbuf, count, datatype);
 529             use_this_sendbuf = tmpbuf;
 530         } else if (io_root == rank) {
 531             tmpbuf = (char *) smpi_get_tmp_recvbuffer(text + (count - 1) * ext);
 532             if (NULL == tmpbuf) {
 533                 return MPI_ERR_INTERN;
 534             }
 535             use_this_recvbuf = tmpbuf;
 536         }
 537     }
 538
 539     /* Use generic reduce with in-order binary tree topology and io_root */
 540     ret = smpi_coll_tuned_ompi_reduce_generic( use_this_sendbuf, use_this_recvbuf, count, datatype,
 541                                           op, io_root, comm,
 542                                           ompi_coll_tuned_topo_build_in_order_bintree(comm),
 543                                           segcount, 0 );
 544     if (MPI_SUCCESS != ret) { return ret; }
 545
 546     /* Clean up */
 547     if (io_root != root) {
 548         if (root == rank) {
 549             /* Receive result from rank io_root to recvbuf */
 550             Request::recv(recvbuf, count, datatype, io_root,
 551                                     COLL_TAG_REDUCE, comm,
 552                                     MPI_STATUS_IGNORE);
 553             if (MPI_IN_PLACE == sendbuf) {
 554               smpi_free_tmp_buffer(use_this_sendbuf);
 555             }
 556
 557         } else if (io_root == rank) {
 558             /* Send result from use_this_recvbuf to root */
 559             Request::send(use_this_recvbuf, count, datatype, root,
 560                                     COLL_TAG_REDUCE,
 561                                     comm);
 562             smpi_free_tmp_buffer(use_this_recvbuf);
 563         }
 564     }
 565
 566     return MPI_SUCCESS;
 567 }
 568
 569 /*
 570  * Linear functions are copied from the BASIC coll module
 571  * they do not segment the message and are simple implementations
 572  * but for some small number of nodes and/or small data sizes they
 573  * are just as fast as tuned/tree based segmenting operations
 574  * and as such may be selected by the decision functions
 575  * These are copied into this module due to the way we select modules
 576  * in V1. i.e. in V2 we will handle this differently and so will not
 577  * have to duplicate code.
 578  * GEF Oct05 after asking Jeff.
 579  */
 580
 581 /* copied function (with appropriate renaming) starts here */
 582
 583 /*
 584  *  reduce_lin_intra
 585  *
 586  *  Function:   - reduction using O(N) algorithm
 587  *  Accepts:    - same as MPI_Reduce()
 588  *  Returns:    - MPI_SUCCESS or error code
 589  */
 590
 591 int
 592 Coll_reduce_ompi_basic_linear::reduce(void *sbuf, void *rbuf, int count,
 593                                           MPI_Datatype dtype,
 594                                           MPI_Op op,
 595                                           int root,
 596                                           MPI_Comm comm)
 597 {
 598     int i, rank, size;
 599     ptrdiff_t true_extent, lb, extent;
 600     char *free_buffer = NULL;
 601     char *pml_buffer = NULL;
 602     char *inplace_temp = NULL;
 603     char *inbuf;
 604
 605     /* Initialize */
 606
 607     rank = comm->rank();
 608     size = comm->size();
 609
 610     XBT_DEBUG("coll:tuned:reduce_intra_basic_linear rank %d", rank);
 611
 612     /* If not root, send data to the root. */
 613
 614     if (rank != root) {
 615         Request::send(sbuf, count, dtype, root,
 616                                 COLL_TAG_REDUCE,
 617                                 comm);
 618         return MPI_SUCCESS;
 619     }
 620
 621     /* see discussion in ompi_coll_basic_reduce_lin_intra about
 622        extent and true extent */
 623     /* for reducing buffer allocation lengths.... */
 624
 625     dtype->extent(&lb, &extent);
 626     true_extent = dtype->get_extent();
 627
 628     if (MPI_IN_PLACE == sbuf) {
 629         sbuf = rbuf;
 630         inplace_temp = (char*)smpi_get_tmp_recvbuffer(true_extent + (count - 1) * extent);
 631         if (NULL == inplace_temp) {
 632             return -1;
 633         }
 634         rbuf = inplace_temp - lb;
 635     }
 636
 637     if (size > 1) {
 638         free_buffer = (char*)smpi_get_tmp_recvbuffer(true_extent + (count - 1) * extent);
 639         pml_buffer = free_buffer - lb;
 640     }
 641
 642     /* Initialize the receive buffer. */
 643
 644     if (rank == (size - 1)) {
 645         Datatype::copy((char*)sbuf, count, dtype,(char*)rbuf, count, dtype);
 646     } else {
 647         Request::recv(rbuf, count, dtype, size - 1,
 648                                 COLL_TAG_REDUCE, comm,
 649                                 MPI_STATUS_IGNORE);
 650     }
 651
 652     /* Loop receiving and calling reduction function (C or Fortran). */
 653
 654     for (i = size - 2; i >= 0; --i) {
 655         if (rank == i) {
 656             inbuf = (char*)sbuf;
 657         } else {
 658             Request::recv(pml_buffer, count, dtype, i,
 659                                     COLL_TAG_REDUCE, comm,
 660                                     MPI_STATUS_IGNORE);
 661             inbuf = pml_buffer;
 662         }
 663
 664         /* Perform the reduction */
 665         if(op!=MPI_OP_NULL) op->apply( inbuf, rbuf, &count, dtype);
 666     }
 667
 668     if (NULL != inplace_temp) {
 669         Datatype::copy(inplace_temp, count, dtype,(char*)sbuf
 670                                                   ,count , dtype);
 671         smpi_free_tmp_buffer(inplace_temp);
 672     }
 673     if (NULL != free_buffer) {
 674         smpi_free_tmp_buffer(free_buffer);
 675     }
 676
 677     /* All done */
 678     return MPI_SUCCESS;
 679 }
 680
 681 /* copied function (with appropriate renaming) ends here */
 682
 683
 684 }
 685 }