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 int destroy_par_info ( p )
  78   char * p ;
  79 {
  80   if ( p != NULL ) RSL_FREE( p ) ;
  81 }
  82
  83 static int 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 void 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   RSL_TO_CHILD_MSG -- Pack force data into a message for a nest point.
 459
 460 @*/
 461
 462
 463 /* common code */
 464 void rsl_lite_to_peerpoint_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   int nbuf ;
 471   int *p, *q ;
 472   char *c, *d ;
 473   int i ;
 474   char mess[4096] ;
 475
 476   RSL_TEST_ERR(buf==NULL,"2nd argument is NULL.  Field allocated?") ;
 477
 478   nbuf = *nbuf_p ;
 479
 480   if ( Sendbufcurs + nbuf >= Sendbufsize ) {
 481     sprintf(mess,"rsl_lite_to_peerpoint_msg: Sendbufcurs + nbuf (%d) would exceed Sendbufsize (%d)\n",
 482            Sendbufcurs + nbuf , Sendbufsize ) ;
 483     RSL_TEST_ERR(1,mess) ;
 484   }
 485
 486   if ( nbuf % sizeof(int) == 0 ) {
 487     for ( p = (int *)buf, q = (int *) &(Sendbuf[Sendbufcurs]), i = 0 ; i < nbuf ; i += sizeof(int) )
 488     {
 489       *q++ = *p++ ;
 490     }
 491   }
 492   else
 493   {
 494     for ( c = buf, d = &(Sendbuf[Sendbufcurs]), i = 0 ; i < nbuf ; i++ )
 495     {
 496       *d++ = *c++ ;
 497     }
 498   }
 499
 500   Sendbufcurs += nbuf ;
 501
 502 }
 503
 504
 505 /* parent->nest */
 506 void RSL_LITE_TO_CHILD_MSG ( nbuf_p, buf )
 507   int_p
 508     nbuf_p ;     /* (I) Number of bytes to be packed. */
 509   char *
 510     buf ;        /* (I) Buffer containing the data to be packed. */
 511 {
 512    rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ;
 513 }
 514
 515 /* nest->parent */
 516 void RSL_LITE_TO_PARENT_MSG ( nbuf_p, buf )
 517   int_p
 518     nbuf_p ;     /* (I) Number of bytes to be packed. */
 519   char *
 520     buf ;        /* (I) Buffer containing the data to be packed. */
 521 {
 522    rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ;
 523 }
 524
 525
 526 /********************************************/
 527
 528 // PARALLELNESTING NOTES
 529 //  what communicator should be passed and what are mytask and ntasks?
 530 //  I think it should be the mom_and_me communicator and the mytask and ntasks from
 531 //  that communicator
 532 //
 533 //  nest if it's parent->nest and the parent if it's nest->parent (we'll see)
 534
 535 /* common code */
 536 void rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, dir )
 537   int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p ;
 538   int dir ;  /* 0 = parent to nest, otherwist nest to parent */
 539 #ifndef STUBMPI
 540   MPI_Comm comm ;
 541 #else
 542   int comm ;
 543 #endif
 544 {
 545   int P ;
 546   char *work ;
 547   int * r ;
 548   bcast_point_desc_t pdesc ;
 549   int curs ;
 550   int msglen, mdest, mtag ;
 551   int ntasks_par, ntasks_nest, ntasks, mytask ;
 552   int  mytask_on_comm ;
 553   int ii, i, j ;
 554   int ig, jg ;
 555   int *sp, *bp ;
 556   int rc ;
 557
 558 #ifndef STUBMPI
 559   ntasks_par = *ntasks_par_p ;
 560   ntasks_nest = *ntasks_nest_p ;
 561   mytask = *mytask_p ;
 562   MPI_Comm_rank( comm, &mytask_on_comm ) ;
 563 #else
 564   ntasks = 1 ;
 565   mytask = 0 ;
 566   mytask_on_comm = 0 ;
 567 #endif
 568
 569   if ( ( mytask_on_comm <  ntasks_par  && dir == 0 )   /* parent in parent->child */
 570     || ( mytask_on_comm >= *offset_p &&
 571          mytask_on_comm < *offset_p + ntasks_nest && dir == 1 )) { /* child  in child->parent */
 572     RSL_TEST_ERR( Plist == NULL,
 573       "rsl_lite_allgather_msgs: rsl_to_child_info or rsl_to_parent_info not called first" ) ;
 574   }
 575
 576 #ifndef STUBMPI
 577   ntasks = MAX(ntasks_par,ntasks_nest+*offset_p) ;
 578 #endif
 579
 580   RSL_TEST_ERR( ntasks >= RSL_MAXPROC ,
 581     "rsl_lite_allgather_msgs: raise the compile time value of MAXPROC" ) ;
 582
 583 #ifndef STUBMPI
 584   MPI_Alltoall(Ssizes,1,MPI_INT, Rsizes,1,MPI_INT,comm);
 585 #else
 586   Rsizes[0] = Ssizes[0];
 587 #endif
 588
 589   for ( Rbufsize = 0, P = 0, Rdisplacements[0] = 0 ; P < ntasks ; P++ )
 590   {
 591     Rdisplacements[P+1] = Rsizes[P] + Rdisplacements[P] ;
 592
 593     Rbufsize += Rsizes[P] ;
 594   }
 595
 596   /* this will be freed later */
 597
 598   Recvbuf = RSL_MALLOC( char , Rbufsize + 3 * sizeof(int) ) ; /* for sentinal record */
 599   Rbufcurs = 0 ;
 600   Rreclen = 0 ;
 601
 602 #ifndef STUBMPI
 603   rc = MPI_Alltoallv ( Sendbuf, Ssizes, Sdisplacements, MPI_BYTE ,
 604                        Recvbuf, Rsizes, Rdisplacements, MPI_BYTE ,  comm ) ;
 605 #else
 606   work = Sendbuf ;
 607   Sendbuf = Recvbuf ;
 608   Recvbuf = work ;
 609 #endif
 610
 611 /* add sentinel to the end of Recvbuf */
 612
 613   r = (int *)&(Recvbuf[Rbufsize + 2 * sizeof(int)]) ;
 614   *r = RSL_INVALID ;
 615
 616   if ( Sendbuf != NULL ) RSL_FREE( Sendbuf ) ;
 617   if ( Plist != NULL ) {
 618     for ( j = 0 ; j < Plist_length ; j++ ) {
 619       destroy_list ( &(Plist[j]), NULL ) ;
 620     }
 621     RSL_FREE( Plist ) ;
 622     Plist = NULL ;
 623     Plist_length = 0 ;
 624   }
 625
 626 }
 627
 628 /* parent->nest */
 629 void RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm )
 630   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 */
 631 {
 632 #ifndef STUBMPI
 633   MPI_Comm comm ;
 634
 635   comm = MPI_Comm_f2c( *Fcomm ) ;
 636 #else
 637   int comm ;
 638 #endif
 639   rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 0 ) ;
 640 }
 641
 642 /* nest->parent */
 643 void RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm )
 644   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 */
 645 {
 646 #ifndef STUBMPI
 647   MPI_Comm comm ;
 648
 649   comm = MPI_Comm_f2c( *Fcomm ) ;
 650 #else
 651   int comm ;
 652 #endif
 653   rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 1 ) ;
 654 }
 655
 656 /********************************************/
 657
 658 /* common code */
 659 void rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p )
 660   int_p
 661     ig_p        /* (O) Global index in M dimension of nest. */
 662    ,jg_p        /* (O) Global index in N dimension of nest. */
 663    ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
 664 {
 665   int ii ;
 666
 667   Rbufcurs = Rbufcurs + Rreclen ;
 668   Rpointcurs = 0 ;
 669   *ig_p    = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
 670   *jg_p    = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
 671 /* read sentinel */
 672   Rreclen  = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
 673   *retval_p = 1 ;
 674   if ( Rreclen == RSL_INVALID ) {
 675     *retval_p = 0 ;
 676     RSL_FREE( Recvbuf ) ;
 677   }
 678
 679 }
 680
 681 /* parent->nest */
 682 void RSL_LITE_FROM_PARENT_INFO ( ig_p, jg_p, retval_p )
 683   int_p
 684     ig_p        /* (O) Global index in M dimension of nest. */
 685    ,jg_p        /* (O) Global index in N dimension of nest. */
 686    ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
 687 {
 688   rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ;
 689 }
 690
 691 /* nest->parent */
 692 void RSL_LITE_FROM_CHILD_INFO ( ig_p, jg_p, retval_p )
 693   int_p
 694     ig_p        /* (O) Global index in M dimension of nest. */
 695    ,jg_p        /* (O) Global index in N dimension of nest. */
 696    ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
 697 {
 698   rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ;
 699 }
 700
 701
 702 /********************************************/
 703
 704 /* common code */
 705 void rsl_lite_from_peerpoint_msg ( len_p, buf )
 706   int_p
 707     len_p ;          /* (I) Number of bytes to unpack. */
 708   int *
 709     buf ;            /* (O) Destination buffer. */
 710 {
 711   int *p, *q ;
 712   char *c, *d ;
 713   int i ;
 714
 715   if ( *len_p % sizeof(int) == 0 ) {
 716     for ( p = (int *)&(Recvbuf[Rbufcurs+Rpointcurs]), q = buf , i = 0 ; i < *len_p ; i += sizeof(int) )
 717     {
 718       *q++ = *p++ ;
 719     }
 720   } else {
 721     for ( c = &(Recvbuf[Rbufcurs+Rpointcurs]), d = (char *) buf , i = 0 ; i < *len_p ; i++ )
 722     {
 723       *d++ = *c++ ;
 724     }
 725   }
 726
 727   Rpointcurs += *len_p ;
 728 }
 729
 730 /* parent->nest */
 731 void RSL_LITE_FROM_PARENT_MSG ( len_p, buf )
 732   int_p
 733     len_p ;          /* (I) Number of bytes to unpack. */
 734   int *
 735     buf ;            /* (O) Destination buffer. */
 736 {
 737   rsl_lite_from_peerpoint_msg ( len_p, buf ) ;
 738 }
 739
 740 /* nest->parent */
 741 void RSL_LITE_FROM_CHILD_MSG ( len_p, buf )
 742   int_p
 743     len_p ;          /* (I) Number of bytes to unpack. */
 744   int *
 745     buf ;            /* (O) Destination buffer. */
 746 {
 747   rsl_lite_from_peerpoint_msg ( len_p, buf ) ;
 748 }
 749
 750
 751 /********************************************/
 752