external/RSL_LITE/rsl_bcast.c

   1 /* #define LEARN_BCAST */
   2 /***********************************************************************
   3
   4                               COPYRIGHT
   5
   6      The following is a notice of limited availability of the code and
   7      Government license and disclaimer which must be included in the
   8      prologue of the code and in all source listings of the code.
   9
  10      Copyright notice
  11        (c) 1977  University of Chicago
  12
  13      Permission is hereby granted to use, reproduce, prepare
  14      derivative works, and to redistribute to others at no charge.  If
  15      you distribute a copy or copies of the Software, or you modify a
  16      copy or copies of the Software or any portion of it, thus forming
  17      a work based on the Software and make and/or distribute copies of
  18      such work, you must meet the following conditions:
  19
  20           a) If you make a copy of the Software (modified or verbatim)
  21              it must include the copyright notice and Government
  22              license and disclaimer.
  23
  24           b) You must cause the modified Software to carry prominent
  25              notices stating that you changed specified portions of
  26              the Software.
  27
  28      This software was authored by:
  29
  30      Argonne National Laboratory
  31      J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
  32      Mathematics and Computer Science Division
  33      Argonne National Laboratory, Argonne, IL  60439
  34
  35      ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES
  36      OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT,
  37      AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A
  38      CONTRACT WITH THE DEPARTMENT OF ENERGY.
  39
  40                       GOVERNMENT LICENSE AND DISCLAIMER
  41
  42      This computer code material was prepared, in part, as an account
  43      of work sponsored by an agency of the United States Government.
  44      The Government is granted for itself and others acting on its
  45      behalf a paid-up, nonexclusive, irrevocable worldwide license in
  46      this data to reproduce, prepare derivative works, distribute
  47      copies to the public, perform publicly and display publicly, and
  48      to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT
  49      NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF
  50      THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
  51      ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
  52      COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS,
  53      PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD
  54      NOT INFRINGE PRIVATELY OWNED RIGHTS.
  55
  56 ***************************************************************************/
  57
  58 #define MAX(a,b) (((a)>(b))?a:b)
  59
  60 #define MOD_9707
  61
  62 #ifndef MS_SUA
  63 # include <stdio.h>
  64 #endif
  65 #include <stdlib.h>
  66 #ifndef STUBMPI
  67 #  include "mpi.h"
  68 #endif
  69 #include "rsl_lite.h"
  70
  71 typedef struct bcast_point_desc {
  72   int ig ;
  73   int jg ;
  74 } bcast_point_desc_t ;
  75
  76
  77 static destroy_par_info ( p )
  78   char * p ;
  79 {
  80   if ( p != NULL ) RSL_FREE( p ) ;
  81 }
  82
  83 static destroy_list( list, dfcn )
  84      rsl_list_t ** list ;          /* pointer to pointer to list */
  85      int (*dfcn)() ;               /* pointer to function for destroying
  86                                       the data field of the list */
  87 {
  88   rsl_list_t *p, *trash ;
  89   if ( list == NULL ) return(0) ;
  90   if ( *list == NULL ) return(0) ;
  91   for ( p = *list ; p != NULL ; )
  92   {
  93     if ( dfcn != NULL ) (*dfcn)( p->data ) ;
  94     trash = p ;
  95     p = p->next ;
  96     RSL_FREE( trash ) ;
  97   }
  98   *list = NULL ;
  99   return(0) ;
 100 }
 101
 102
 103 static rsl_list_t *Xlist, *Xp, *Xprev ;
 104 static rsl_list_t *stage ;
 105 static int stage_len = 0 ;              /* 96/3/15 */
 106
 107 static int  Sendbufsize ;
 108 static int  Sendbufcurs ;
 109 static char *Sendbuf ;
 110 static int  Sdisplacements[RSL_MAXPROC] ;
 111 static int  Ssizes[RSL_MAXPROC] ;
 112
 113 static int  Recsizeindex ;
 114
 115 static int  Rbufsize ;
 116 static int  Rbufcurs ;
 117 static int  Rpointcurs ;
 118 static char *Recvbuf ;
 119 static int  Rdisplacements[RSL_MAXPROC+1] ;
 120 static int  Rsizes[RSL_MAXPROC] ;
 121 static int  Rreclen ;
 122
 123 static int s_d ;
 124 static int s_nst ;
 125 static int s_msize ;
 126 static int s_idim ;
 127 static int s_jdim ;
 128 static int s_idim_nst ;
 129 static int s_jdim_nst ;
 130 static int s_irax_n ;
 131 static int s_irax_m ;
 132 static int s_ntasks_nest_x ;
 133 static int s_ntasks_nest_y ;
 134 static int s_ntasks_par_x ;
 135 static int s_ntasks_par_y ;
 136 static rsl_list_t **Plist ;
 137 static int Plist_length = 0 ;
 138 static int Psize[RSL_MAXPROC] ;
 139 static char *s_parent_msgs ;
 140 static int s_parent_msgs_curs ;
 141 static int s_remaining ;  /* number of bytes left in a parent message before
 142                            the next point descriptor */
 143 static int alltasks, offset ;
 144
 145 /* add a field to a message outgoing for the specified child domain cell */
 146 /* relies on rsl_ready_bcast having been called already */
 147 /* sends are specified in terms of coarse domain */
 148
 149 static int s_i, s_j, s_ig, s_jg, s_cm, s_cn,
 150            s_nig, s_njg ;
 151
 152 static int Pcurs ;
 153 static rsl_list_t *Pptr ;
 154
 155 #ifdef LEARN_BCAST
 156 static int s_putmsg = 0 ;
 157 #endif
 158
 159 // NOTES for PARALLELNESTING
 160 // This routine is building a list of destination processes to send to on a communicator that .
 161 // It needs the minor number of tasks on the nest's MPI mesh (just pass that in)
 162 // Otherwise it doesn't need a communicator
 163
 164 RSL_LITE_NESTING_RESET (
 165                        )
 166 {
 167   int j ;
 168
 169   for ( j = 0 ; j < RSL_MAXPROC ; j++ ) {
 170     Ssizes[j] = 0 ;
 171     Sdisplacements[j] = 0 ;
 172     Rsizes[j] = 0 ;
 173     Rdisplacements[j] = 0 ;
 174   }
 175   Rdisplacements[RSL_MAXPROC] = 0 ;
 176   if ( Plist != NULL ) {
 177     for ( j = 0 ; j < Plist_length ; j++ ) {
 178       destroy_list ( &(Plist[j]), NULL ) ;
 179     }
 180     RSL_FREE( Plist ) ;
 181     Plist = NULL ;
 182   }
 183 }
 184
 185 /* parent->nest */
 186 void RSL_LITE_TO_CHILD_INFO ( msize_p,                        /* number of tasks in minor dim of nest's mesh */
 187                          cips_p, cipe_p, cjps_p, cjpe_p, /* patch dims of SOURCE DOMAIN */
 188                          iids_p, iide_p, ijds_p, ijde_p, /* domain dims of INTERMEDIATE DOMAIN */
 189                          nids_p, nide_p, njds_p, njde_p, /* domain dims of CHILD DOMAIN */
 190                          pgr_p,  shw_p ,                 /* nest ratio and stencil half width */
 191                          offset_p,                         /* first task of the nest in me_and_mom communicator */
 192                          ntasks_par_x_p , ntasks_par_y_p ,       /* proc counts in x and y */
 193                          ntasks_nest_x_p , ntasks_nest_y_p ,       /* proc counts in x and y */
 194                          min_subdomain ,                 /* minimum width allowed for a subdomain in a dim ON PARENT */
 195                          icoord_p, jcoord_p,
 196                          idim_cd_p, jdim_cd_p,
 197                          ig_p, jg_p,
 198                          retval_p )
 199
 200   int_p
 201      cips_p, cipe_p, cjps_p, cjpe_p   /* (i) c.d. patch dims */
 202     ,iids_p, iide_p, ijds_p, ijde_p   /* (i) n.n. global dims -- in WRF this will be intermediate domain */
 203     ,nids_p, nide_p, njds_p, njde_p   /* (i) n.n. global dims */
 204     ,pgr_p                            /* nesting ratio */
 205     ,offset_p                         /* first task of the nest in me_and_mom communicator */
 206     ,ntasks_nest_x_p , ntasks_nest_y_p          /* proc counts in x and y */
 207     ,ntasks_par_x_p , ntasks_par_y_p          /* proc counts in x and y */
 208     ,min_subdomain
 209     ,icoord_p       /* i coordinate of nest in cd */
 210     ,jcoord_p       /* j coordinate of nest in cd */
 211     ,shw_p          /* stencil half width */
 212     ,idim_cd_p      /* i width of nest in cd */
 213     ,jdim_cd_p      /* j width of nest in cd */
 214     ,msize_p        /* (I) Message size in bytes. */
 215     ,ig_p           /* (O) Global N index of parent domain point. */
 216     ,jg_p           /* (O) Global N index of parent domain point. */
 217     ,retval_p ;     /* (O) =1 if a valid point returned; =0 (zero) otherwise. */
 218 {
 219   int P, Px, Py ;
 220
 221   rsl_list_t *q ;
 222   int *r ;
 223   int i, j, ni, nj ;
 224   int coords[2] ;
 225   int ierr ;
 226
 227   if ( Plist == NULL ) {
 228     s_ntasks_par_x = *ntasks_par_x_p ;
 229     s_ntasks_par_y = *ntasks_par_y_p ;
 230     s_ntasks_nest_x = *ntasks_nest_x_p ;
 231     s_ntasks_nest_y = *ntasks_nest_y_p ;
 232     offset = *offset_p ;
 233     alltasks = MAX( s_ntasks_nest_x*s_ntasks_nest_y + offset, s_ntasks_par_x*s_ntasks_par_y ) ;
 234
 235 #if 0
 236 fprintf(stderr,"s_ntasks_par_x %d\n",s_ntasks_par_x)  ;
 237 fprintf(stderr,"s_ntasks_par_y %d\n",s_ntasks_par_y)  ;
 238 fprintf(stderr,"s_ntasks_nest_x %d\n",s_ntasks_nest_x)  ;
 239 fprintf(stderr,"s_ntasks_nest_y %d\n",s_ntasks_nest_y)  ;
 240 fprintf(stderr,"%s %d offset %d\n",__FILE__,__LINE__,offset)  ;
 241 fprintf(stderr,"%s %d alltasks %d\n",__FILE__,__LINE__,alltasks)  ;
 242 fprintf(stderr,"%s %d a %d b %d\n",__FILE__,__LINE__,s_ntasks_nest_x*s_ntasks_nest_y+offset,s_ntasks_par_x*s_ntasks_par_y)  ;
 243 #endif
 244
 245     /* construct Plist */
 246     Sendbufsize = 0 ;
 247     Plist = RSL_MALLOC( rsl_list_t * , alltasks ) ;  /* big enough for nest points */
 248     Plist_length = alltasks ;
 249    /* big enough for the mom and me communicator, which includes tasks for the parent and the nest */
 250     for ( j = 0 ; j < alltasks ; j++ ) {
 251        Plist[j] = NULL ;
 252        Sdisplacements[j] = 0 ;
 253        Ssizes[j] = 0 ;
 254     }
 255     ierr = 0 ;
 256     for ( j = *cjps_p ; j <= *cjpe_p ; j++ )
 257     {
 258       for ( i = *cips_p ; i <= *cipe_p ; i++ )
 259       {
 260         if ( ( *jcoord_p <= j && j <= *jcoord_p+*jdim_cd_p-1 ) && ( *icoord_p <= i && i <= *icoord_p+*idim_cd_p-1 ) ) {
 261            ni = ( i - (*icoord_p + *shw_p) ) * *pgr_p + 1 + 1 ; /* add 1 to give center point */
 262            nj = ( j - (*jcoord_p + *shw_p) ) * *pgr_p + 1 + 1 ;
 263
 264 #ifndef STUBMPI
 265            TASK_FOR_POINT ( &ni, &nj, nids_p, nide_p, njds_p, njde_p, &s_ntasks_nest_x, &s_ntasks_nest_y, &Px, &Py,
 266                             min_subdomain, min_subdomain, &ierr ) ;
 267            P = Px + Py * *ntasks_nest_x_p + offset ;
 268 //           coords[1] = Px ; coords[0] = Py ;
 269 //           MPI_Cart_rank( *comm, coords, &P ) ;
 270 // PARALLELNESTING
 271 // adjust P so that is the rank in the intercomm_to_kid communicator for this parent/nest pair
 272 //fprintf(stderr,"after tfp ni %d nj %d Px %d Py %d P %d ntx %d nty %d\n",ni,nj,Px,Py,P,*ntasks_nest_x_p,*ntasks_nest_y_p) ;
 273
 274 #else
 275            P = 0 ;
 276 #endif
 277            q = RSL_MALLOC( rsl_list_t , 1 ) ;
 278            q->info1 = i ;
 279            q->info2 = j ;
 280            q->next = Plist[P] ;
 281            Plist[P] = q ;
 282            Sendbufsize += *msize_p + 3 * sizeof( int ) ;  /* point data plus 3 ints for i, j, and size */
 283         }
 284       }
 285     }
 286     if ( ierr != 0 ) {
 287       fprintf(stderr,"rsl_to_child_info: ") ;
 288       TASK_FOR_POINT_MESSAGE () ;
 289     }
 290     Sendbuf = RSL_MALLOC( char , Sendbufsize ) ;
 291     Sendbufcurs = 0 ;
 292     Recsizeindex = -1 ;
 293     Pcurs = -1 ;
 294     Pptr = NULL ;
 295   }
 296
 297   if ( Pptr != NULL ) {
 298     Pptr = Pptr->next ;
 299   }
 300
 301   if ( Recsizeindex >= 0 ) {
 302           r = (int *) &(Sendbuf[Recsizeindex]) ;
 303           *r = Sendbufcurs - Recsizeindex + 2 * sizeof(int) ;
 304           Ssizes[Pcurs] += *r ;
 305   }
 306
 307   while ( Pptr == NULL ) {
 308       Pcurs++ ;
 309       while ( Pcurs < alltasks && Plist[Pcurs] == NULL  ) Pcurs++ ;
 310       if ( Pcurs < alltasks ) {
 311         Sdisplacements[Pcurs] = Sendbufcurs ;
 312         Ssizes[Pcurs] = 0 ;
 313         Pptr = Plist[Pcurs] ;
 314       } else {
 315         *retval_p = 0 ;
 316         return ;  /* done */
 317       }
 318   }
 319
 320   *ig_p = Pptr->info1 ;
 321   *jg_p = Pptr->info2 ;
 322
 323   r = (int *) &(Sendbuf[Sendbufcurs]) ;
 324   *r++ = Pptr->info1 ; Sendbufcurs += sizeof(int) ;  /* ig to buffer */
 325   *r++ = Pptr->info2 ; Sendbufcurs += sizeof(int) ;  /* jg to buffer */
 326   Recsizeindex = Sendbufcurs ;
 327   *r++ =           0 ; Sendbufcurs += sizeof(int) ;  /* store start for size */
 328   *retval_p = 1 ;
 329
 330   return ;
 331 }
 332
 333 /********************************************/
 334
 335 /* nest->parent */
 336 void RSL_LITE_TO_PARENT_INFO ( msize_p,
 337                           nips_p, nipe_p, njps_p, njpe_p, /* patch dims of SOURCE DOMAIN (CHILD) */
 338                           cids_p, cide_p, cjds_p, cjde_p, /* domain dims of TARGET DOMAIN (PARENT) */
 339                           offset_p,
 340                           ntasks_par_x_p , ntasks_par_y_p ,       /* proc counts in x and y */
 341                           ntasks_nest_x_p , ntasks_nest_y_p ,       /* proc counts in x and y */
 342                           min_subdomain ,
 343                           icoord_p, jcoord_p,
 344                           idim_cd_p, jdim_cd_p,
 345                           ig_p, jg_p,
 346                           retval_p )
 347   int_p
 348      nips_p, nipe_p, njps_p, njpe_p   /* (i) n.d. patch dims */
 349     ,cids_p, cide_p, cjds_p, cjde_p   /* (i) n.n. global dims */
 350     ,offset_p
 351     ,ntasks_nest_x_p , ntasks_nest_y_p          /* proc counts in x and y */
 352     ,ntasks_par_x_p , ntasks_par_y_p          /* proc counts in x and y */
 353     ,min_subdomain
 354     ,icoord_p       /* i coordinate of nest in cd */
 355     ,jcoord_p       /* j coordinate of nest in cd */
 356     ,idim_cd_p      /* i width of nest in cd */
 357     ,jdim_cd_p      /* j width of nest in cd */
 358     ,msize_p        /* (I) Message size in bytes. */
 359     ,ig_p           /* (O) Global N index of parent domain point. */
 360     ,jg_p           /* (O) Global N index of parent domain point. */
 361     ,retval_p ;     /* (O) =1 if a valid point returned; =0 (zero) otherwise. */
 362 {
 363   int P, Px, Py ;
 364   rsl_list_t *q ;
 365   int *r ;
 366   int i, j ;
 367   int coords[2] ;
 368   int ierr ;
 369
 370   if ( Plist == NULL ) {
 371     s_ntasks_nest_x = *ntasks_nest_x_p ;
 372     s_ntasks_nest_y = *ntasks_nest_y_p ;
 373     s_ntasks_par_x = *ntasks_par_x_p ;
 374     s_ntasks_par_y = *ntasks_par_y_p ;
 375     offset = *offset_p ;
 376     alltasks = MAX( s_ntasks_nest_x*s_ntasks_nest_y + offset, s_ntasks_par_x*s_ntasks_par_y ) ;
 377
 378     /* construct Plist */
 379     Sendbufsize = 0 ;
 380     Plist = RSL_MALLOC( rsl_list_t * , alltasks ) ;
 381     Plist_length = alltasks ;
 382     for ( j = 0 ; j < alltasks ; j++ ) {
 383        Plist[j] = NULL ;
 384        Sdisplacements[j] = 0 ;
 385        Ssizes[j] = 0 ;
 386     }
 387     ierr = 0 ;
 388     for ( j = *njps_p ; j <= *njpe_p ; j++ )
 389     {
 390       for ( i = *nips_p ; i <= *nipe_p ; i++ )
 391       {
 392         if ( ( *jcoord_p <= j && j <= *jcoord_p+*jdim_cd_p-1 ) && ( *icoord_p <= i && i <= *icoord_p+*idim_cd_p-1 ) ) {
 393 #ifndef STUBMPI
 394           TASK_FOR_POINT ( &i, &j, cids_p, cide_p, cjds_p, cjde_p, &s_ntasks_par_x, &s_ntasks_par_y, &Px, &Py,
 395                            min_subdomain, min_subdomain, &ierr ) ;
 396           P = Px + Py * *ntasks_par_x_p ;  // we are computing parent task numbers, so no offset
 397 #else
 398           P = 0 ;
 399 #endif
 400           q = RSL_MALLOC( rsl_list_t , 1 ) ;
 401           q->info1 = i ;
 402           q->info2 = j ;
 403           q->next = Plist[P] ;
 404           Plist[P] = q ;
 405           Sendbufsize += *msize_p + 3 * sizeof( int ) ;  /* point data plus 3 ints for i, j, and size */
 406         }
 407       }
 408     }
 409     if ( ierr != 0 ) {
 410       fprintf(stderr,"rsl_to_parent_info: ") ;
 411       TASK_FOR_POINT_MESSAGE () ;
 412     }
 413     Sendbuf = RSL_MALLOC( char , Sendbufsize ) ;
 414     Sendbufcurs = 0 ;
 415     Recsizeindex = -1 ;
 416     Pcurs = -1 ;
 417     Pptr = NULL ;
 418   }
 419   if ( Pptr != NULL ) {
 420     Pptr = Pptr->next ;
 421   }
 422
 423   if ( Recsizeindex >= 0 ) {
 424           r = (int *) &(Sendbuf[Recsizeindex]) ;
 425           *r = Sendbufcurs - Recsizeindex + 2 * sizeof(int) ;
 426           Ssizes[Pcurs] += *r ;
 427   }
 428
 429   while ( Pptr == NULL ) {
 430       Pcurs++ ;
 431       while ( Pcurs < alltasks && Plist[Pcurs] == NULL ) Pcurs++ ;
 432       if ( Pcurs < alltasks ) {
 433         Sdisplacements[Pcurs] = Sendbufcurs ;
 434         Ssizes[Pcurs] = 0 ;
 435         Pptr = Plist[Pcurs] ;
 436       } else {
 437         *retval_p = 0 ;
 438         return ;  /* done */
 439       }
 440   }
 441
 442   *ig_p = Pptr->info1 ;
 443   *jg_p = Pptr->info2 ;
 444
 445   r = (int *) &(Sendbuf[Sendbufcurs]) ;
 446   *r++ = Pptr->info1 ; Sendbufcurs += sizeof(int) ;  /* ig to buffer */
 447   *r++ = Pptr->info2 ; Sendbufcurs += sizeof(int) ;  /* jg to buffer */
 448   Recsizeindex = Sendbufcurs ;
 449   *r++ =           0 ; Sendbufcurs += sizeof(int) ;  /* store start for size */
 450   *retval_p = 1 ;
 451
 452   return ;
 453 }
 454
 455
 456 /********************************************/
 457
 458 /*@
 459   RSL_TO_CHILD_MSG -- Pack force data into a message for a nest point.
 460
 461 @*/
 462
 463 /* parent->nest */
 464 RSL_LITE_TO_CHILD_MSG ( nbuf_p, buf )
 465   int_p
 466     nbuf_p ;     /* (I) Number of bytes to be packed. */
 467   char *
 468     buf ;        /* (I) Buffer containing the data to be packed. */
 469 {
 470    rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ;
 471 }
 472
 473 /* nest->parent */
 474 RSL_LITE_TO_PARENT_MSG ( nbuf_p, buf )
 475   int_p
 476     nbuf_p ;     /* (I) Number of bytes to be packed. */
 477   char *
 478     buf ;        /* (I) Buffer containing the data to be packed. */
 479 {
 480    rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ;
 481 }
 482
 483 /* common code */
 484 rsl_lite_to_peerpoint_msg ( nbuf_p, buf )
 485   int_p
 486     nbuf_p ;     /* (I) Number of bytes to be packed. */
 487   char *
 488     buf ;        /* (I) Buffer containing the data to be packed. */
 489 {
 490   int nbuf ;
 491   int *p, *q ;
 492   char *c, *d ;
 493   int i ;
 494   char mess[4096] ;
 495
 496   RSL_TEST_ERR(buf==NULL,"2nd argument is NULL.  Field allocated?") ;
 497
 498   nbuf = *nbuf_p ;
 499
 500   if ( Sendbufcurs + nbuf >= Sendbufsize ) {
 501     sprintf(mess,"rsl_lite_to_peerpoint_msg: Sendbufcurs + nbuf (%d) would exceed Sendbufsize (%d)\n",
 502            Sendbufcurs + nbuf , Sendbufsize ) ;
 503     RSL_TEST_ERR(1,mess) ;
 504   }
 505
 506   if ( nbuf % sizeof(int) == 0 ) {
 507     for ( p = (int *)buf, q = (int *) &(Sendbuf[Sendbufcurs]), i = 0 ; i < nbuf ; i += sizeof(int) )
 508     {
 509       *q++ = *p++ ;
 510     }
 511   }
 512   else
 513   {
 514     for ( c = buf, d = &(Sendbuf[Sendbufcurs]), i = 0 ; i < nbuf ; i++ )
 515     {
 516       *d++ = *c++ ;
 517     }
 518   }
 519
 520   Sendbufcurs += nbuf ;
 521
 522 }
 523
 524 /********************************************/
 525
 526 // PARALLELNESTING NOTES
 527 //  what communicator should be passed and what are mytask and ntasks?
 528 //  I think it should be the mom_and_me communicator and the mytask and ntasks from
 529 //  that communicator
 530 //
 531 //  nest if it's parent->nest and the parent if it's nest->parent (we'll see)
 532
 533 /* parent->nest */
 534 RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm )
 535   int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ;  /* offset is the id of the first task in the nest set */
 536 {
 537 #ifndef STUBMPI
 538   MPI_Comm comm ;
 539
 540   comm = MPI_Comm_f2c( *Fcomm ) ;
 541 #else
 542   int comm ;
 543 #endif
 544   rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 0 ) ;
 545 }
 546
 547 /* nest->parent */
 548 RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm )
 549   int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ;  /* offset is the id of the first task in the nest set */
 550 {
 551 #ifndef STUBMPI
 552   MPI_Comm comm ;
 553
 554   comm = MPI_Comm_f2c( *Fcomm ) ;
 555 #else
 556   int comm ;
 557 #endif
 558   rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 1 ) ;
 559 }
 560
 561 /* common code */
 562 rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, dir )
 563   int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p ;
 564   int dir ;  /* 0 = parent to nest, otherwist nest to parent */
 565 #ifndef STUBMPI
 566   MPI_Comm comm ;
 567 #else
 568   int comm ;
 569 #endif
 570 {
 571   int P ;
 572   char *work ;
 573   int * r ;
 574   bcast_point_desc_t pdesc ;
 575   int curs ;
 576   int msglen, mdest, mtag ;
 577   int ntasks_par, ntasks_nest, ntasks, mytask ;
 578   int  mytask_on_comm ;
 579   int ii, i, j ;
 580   int ig, jg ;
 581   int *sp, *bp ;
 582   int rc ;
 583
 584 #ifndef STUBMPI
 585   ntasks_par = *ntasks_par_p ;
 586   ntasks_nest = *ntasks_nest_p ;
 587   mytask = *mytask_p ;
 588   MPI_Comm_rank( comm, &mytask_on_comm ) ;
 589 #else
 590   ntasks = 1 ;
 591   mytask = 0 ;
 592   mytask_on_comm = 0 ;
 593 #endif
 594
 595   if ( ( mytask_on_comm <  ntasks_par  && dir == 0 )   /* parent in parent->child */
 596     || ( mytask_on_comm >= *offset_p &&
 597          mytask_on_comm < *offset_p + ntasks_nest && dir == 1 )) { /* child  in child->parent */
 598     RSL_TEST_ERR( Plist == NULL,
 599       "rsl_lite_allgather_msgs: rsl_to_child_info or rsl_to_parent_info not called first" ) ;
 600   }
 601
 602 #ifndef STUBMPI
 603   ntasks = MAX(ntasks_par,ntasks_nest+*offset_p) ;
 604 #endif
 605
 606   RSL_TEST_ERR( ntasks >= RSL_MAXPROC ,
 607     "rsl_lite_allgather_msgs: raise the compile time value of MAXPROC" ) ;
 608
 609 #ifndef STUBMPI
 610   MPI_Alltoall(Ssizes,1,MPI_INT, Rsizes,1,MPI_INT,comm);
 611 #else
 612   Rsizes[0] = Ssizes[0];
 613 #endif
 614
 615   for ( Rbufsize = 0, P = 0, Rdisplacements[0] = 0 ; P < ntasks ; P++ )
 616   {
 617     Rdisplacements[P+1] = Rsizes[P] + Rdisplacements[P] ;
 618
 619     Rbufsize += Rsizes[P] ;
 620   }
 621
 622   /* this will be freed later */
 623
 624   Recvbuf = RSL_MALLOC( char , Rbufsize + 3 * sizeof(int) ) ; /* for sentinal record */
 625   Rbufcurs = 0 ;
 626   Rreclen = 0 ;
 627
 628 #ifndef STUBMPI
 629   rc = MPI_Alltoallv ( Sendbuf, Ssizes, Sdisplacements, MPI_BYTE ,
 630                        Recvbuf, Rsizes, Rdisplacements, MPI_BYTE ,  comm ) ;
 631 #else
 632   work = Sendbuf ;
 633   Sendbuf = Recvbuf ;
 634   Recvbuf = work ;
 635 #endif
 636
 637 /* add sentinel to the end of Recvbuf */
 638
 639   r = (int *)&(Recvbuf[Rbufsize + 2 * sizeof(int)]) ;
 640   *r = RSL_INVALID ;
 641
 642   if ( Sendbuf != NULL ) RSL_FREE( Sendbuf ) ;
 643   if ( Plist != NULL ) {
 644     for ( j = 0 ; j < Plist_length ; j++ ) {
 645       destroy_list ( &(Plist[j]), NULL ) ;
 646     }
 647     RSL_FREE( Plist ) ;
 648     Plist = NULL ;
 649     Plist_length = 0 ;
 650   }
 651
 652 }
 653
 654 /********************************************/
 655
 656 /* parent->nest */
 657 RSL_LITE_FROM_PARENT_INFO ( ig_p, jg_p, retval_p )
 658   int_p
 659     ig_p        /* (O) Global index in M dimension of nest. */
 660    ,jg_p        /* (O) Global index in N dimension of nest. */
 661    ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
 662 {
 663   rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ;
 664 }
 665
 666 /* nest->parent */
 667 RSL_LITE_FROM_CHILD_INFO ( ig_p, jg_p, retval_p )
 668   int_p
 669     ig_p        /* (O) Global index in M dimension of nest. */
 670    ,jg_p        /* (O) Global index in N dimension of nest. */
 671    ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
 672 {
 673   rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ;
 674 }
 675
 676 /* common code */
 677 rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p )
 678   int_p
 679     ig_p        /* (O) Global index in M dimension of nest. */
 680    ,jg_p        /* (O) Global index in N dimension of nest. */
 681    ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
 682 {
 683   int ii ;
 684
 685   Rbufcurs = Rbufcurs + Rreclen ;
 686   Rpointcurs = 0 ;
 687   *ig_p    = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
 688   *jg_p    = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
 689 /* read sentinel */
 690   Rreclen  = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
 691   *retval_p = 1 ;
 692   if ( Rreclen == RSL_INVALID ) {
 693     *retval_p = 0 ;
 694     RSL_FREE( Recvbuf ) ;
 695   }
 696
 697 }
 698
 699 /********************************************/
 700
 701 /* parent->nest */
 702 RSL_LITE_FROM_PARENT_MSG ( len_p, buf )
 703   int_p
 704     len_p ;          /* (I) Number of bytes to unpack. */
 705   int *
 706     buf ;            /* (O) Destination buffer. */
 707 {
 708   rsl_lite_from_peerpoint_msg ( len_p, buf ) ;
 709 }
 710
 711 /* nest->parent */
 712 RSL_LITE_FROM_CHILD_MSG ( len_p, buf )
 713   int_p
 714     len_p ;          /* (I) Number of bytes to unpack. */
 715   int *
 716     buf ;            /* (O) Destination buffer. */
 717 {
 718   rsl_lite_from_peerpoint_msg ( len_p, buf ) ;
 719 }
 720
 721 /* common code */
 722 rsl_lite_from_peerpoint_msg ( len_p, buf )
 723   int_p
 724     len_p ;          /* (I) Number of bytes to unpack. */
 725   int *
 726     buf ;            /* (O) Destination buffer. */
 727 {
 728   int *p, *q ;
 729   char *c, *d ;
 730   int i ;
 731
 732   if ( *len_p % sizeof(int) == 0 ) {
 733     for ( p = (int *)&(Recvbuf[Rbufcurs+Rpointcurs]), q = buf , i = 0 ; i < *len_p ; i += sizeof(int) )
 734     {
 735       *q++ = *p++ ;
 736     }
 737   } else {
 738     for ( c = &(Recvbuf[Rbufcurs+Rpointcurs]), d = (char *) buf , i = 0 ; i < *len_p ; i++ )
 739     {
 740       *d++ = *c++ ;
 741     }
 742   }
 743
 744   Rpointcurs += *len_p ;
 745 }
 746
 747 /********************************************/
 748