wrfv2_fire/external/RSL/RSL/comp_sten.c

   1 /***********************************************************************
   2
   3                               COPYRIGHT
   4
   5      The following is a notice of limited availability of the code and
   6      Government license and disclaimer which must be included in the
   7      prologue of the code and in all source listings of the code.
   8
   9      Copyright notice
  10        (c) 1977  University of Chicago
  11
  12      Permission is hereby granted to use, reproduce, prepare
  13      derivative works, and to redistribute to others at no charge.  If
  14      you distribute a copy or copies of the Software, or you modify a
  15      copy or copies of the Software or any portion of it, thus forming
  16      a work based on the Software and make and/or distribute copies of
  17      such work, you must meet the following conditions:
  18
  19           a) If you make a copy of the Software (modified or verbatim)
  20              it must include the copyright notice and Government
  21              license and disclaimer.
  22
  23           b) You must cause the modified Software to carry prominent
  24              notices stating that you changed specified portions of
  25              the Software.
  26
  27      This software was authored by:
  28
  29      Argonne National Laboratory
  30      J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
  31      Mathematics and Computer Science Division
  32      Argonne National Laboratory, Argonne, IL  60439
  33
  34      ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES
  35      OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT,
  36      AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A
  37      CONTRACT WITH THE DEPARTMENT OF ENERGY.
  38
  39                       GOVERNMENT LICENSE AND DISCLAIMER
  40
  41      This computer code material was prepared, in part, as an account
  42      of work sponsored by an agency of the United States Government.
  43      The Government is granted for itself and others acting on its
  44      behalf a paid-up, nonexclusive, irrevocable worldwide license in
  45      this data to reproduce, prepare derivative works, distribute
  46      copies to the public, perform publicly and display publicly, and
  47      to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT
  48      NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF
  49      THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
  50      ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
  51      COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS,
  52      PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD
  53      NOT INFRINGE PRIVATELY OWNED RIGHTS.
  54
  55 ***************************************************************************/
  56
  57 #include <stdio.h>
  58 #include <stdlib.h>
  59 #include "rsl.h"
  60
  61 /*
  62    Here's a drawing of the graph this routine is trying to construct:
  63
  64       (stencil_desc)
  65         |      |
  66         |      |
  67         |    array of message_descs corresponding to stencil pts
  68         |      msg1 msg2 msg3 msg4 ...
  69         |       0    1    2    3
  70         |                       \
  71    array of processor lists      \ <---pointers back to message structures
  72    on list for each domain        \        |
  73      |                            |        |
  74   d                               ^      \ v       +-------------------------+
  75   o (0) -->  procrec  -->         |       \        |there is one node for    |
  76   m            |                  |        \       |each physical processor  |
  77   a (1)        |                  |         \      |this processor will need |
  78   i            |                  ^          \     |to communicate with for  |
  79   n  .         |                  |           \    |this stencil.            |
  80      .         v                  |            ^   +-------------------------+
  81      .      (list_t)              |            |
  82                |  \               ^            ^     +-------------------------+
  83                | ( ptrec ) --> (list_t) --> (list_t) |1 for each msg associated|
  84                |     |                               |with the point           |
  85                |      \                              +-------------------------+
  86                v       \+-------------------------------------------------+
  87             (list_t)    |points to the entry for the local point in domain|
  88                |        |data structure.                                  |
  89                |        +-------------------------------------------------+
  90                .
  91                .
  92                .
  93
  94 **************
  95   Algorithm:
  96
  97     P is a remote processor, M is me
  98
  99  1  To work out sends to P from M:
 100  1.1   for each ghost point GP from P
 101  1.1.1   for each point p on GP's stencil
 102  1.1.1.1    if p is on M
 103  1.1.1.1.1     add p to list of points going to P (if not already on)
 104  1.1.1.1.2     add message from p to p's entry in the aforementioned list
 105
 106  2  To work out receives from P to M:
 107  2.1   for each ghost point GP from P
 108  2.1.1   for each point p on GP's stencil
 109  2.1.1.1    if p is on M
 110  2.1.1.1.1     add GP to list of points being sent from P (if not already on)
 111  2.1.1.1.2     add message from GP to GP's entry in the aforementioned list
 112
 113     Combined algorithm;
 114
 115  1  To work out receives from P to M:
 116  1.1   for each ghost point GP from P
 117  1.1.1   for each point p on GP's stencil
 118  1.1.1.1    if p is on M
 119  1.1.1.1.1     add p to list of points going to P (if not already on)
 120  1.1.1.1.2     add message from p to p's entry in the aforementioned list
 121  2.1.1.1.1     add GP to list of points being sent from P (if not already on)
 122  2.1.1.1.2     add message from GP to GP's entry in the aforementioned list
 123
 124 */
 125
 126 /* used by compile_stencil, below */
 127 static stencil_desc_t *sd ;            /* set in compile_stencil */
 128 static rsl_procrec_t *procrec ;        /* set in compile_stencil */
 129 static int send_accum ;
 130 static int recv_accum ;
 131
 132 #if 0
 133 /* this is a linked list that is used for the receives from the remote
 134    processor (the GP list in the above algorithmic descriptions).  We are
 135    only counting bytes for these messages (to allocated the correctly sized
 136    buffers) so this is just a temporary data structure that is cleaned up
 137    on each call to rsl_compile_stencil */
 138 static rsl_list_t *recv_point_list = NULL ;   /* 940308 */
 139 #endif
 140
 141 dstry_ptrec_list( recv_ptrec )
 142   rsl_ptrec_t *recv_ptrec ;
 143 {
 144   destroy_list( &(recv_ptrec->recv_messages), NULL ) ;
 145 }
 146
 147 rsl_processor_t idx_ ;
 148
 149 #ifdef NEC_TUNE
 150 /*
 151    NECNOTE:
 152    quick tables to speed up link list searching in routine check_local_pts.
 153    tbl_'id'_... used for searching rsl_point_t id's.
 154 */
 155 static int ntbl_id_max = 128 ; /* Note first allocation will be of size 256 */
 156 static int ntbl_id = 0 ;
 157 static rsl_point_id_t *tbl_id = NULL ;
 158 static rsl_ptrec_t **tbl_ptrec = NULL ;
 159 static rsl_procrec_t *prev_procrec = NULL ;
 160 #endif
 161 /* 1.1.1 (continued) */
 162 /* this routine is called for each point on the ghost point's stencil */
 163 check_local_pts( d, m, n, hm, hn, pt, ipt )
 164   rsl_index_t d ;               /* domain index */
 165   rsl_index_t m, n ;            /* this point */
 166   rsl_index_t hm, hn ;          /* home point (whose stencil I'm on)  */
 167   rsl_index_t pt ;              /* point in stencil */
 168   rsl_index_t ipt ;             /* inverse point in stencil */
 169 {
 170   int mlen ;                    /* length of minor domain dimension */
 171   rsl_fldspec_t *fp, *fpm, *prev, *new ;
 172   int message, found ;
 173   rsl_processor_t  P ;
 174   rsl_point_id_t id ;
 175   rsl_ptrec_t *ptrec, *recv_ptrec ;
 176   int recv_npts ;       /* dummy */
 177   rsl_list_t *lp ;
 178   message_desc_t *msg ;
 179   rsl_domain_info_t *dinfo ;
 180   rsl_point_t *domain ;
 181 #ifdef NEC_TUNE
 182   int i ;
 183 #endif
 184
 185   dinfo = &(domain_info[d]) ;
 186   domain = dinfo->domain ;
 187   mlen = dinfo->len_m ;
 188
 189   /* P is proc of ghost point */
 190   P = domain[INDEX_2(hn,hm,mlen)].P ;
 191 /* 1.1.1.1 */
 192   if ( rsl_c_comp2phys_proc (domain[INDEX_2(n,m,mlen)].P) == rsl_myproc )
 193   {
 194 /* 1.1.1.1.1 */
 195     id = POINTID(d,n,m) ;
 196     found = 0 ;
 197 #ifndef NEC_TUNE
 198     for ( lp = procrec->point_list ; lp != NULL ; lp = lp->next )
 199     {
 200       ptrec = (rsl_ptrec_t *)lp->data ;
 201       if ( ptrec->pt->id == id )
 202       {
 203         found = 1 ;
 204         break ;
 205       }
 206     }
 207 #else
 208     if ( prev_procrec != procrec )
 209     {
 210       ntbl_id = 0 ;
 211       prev_procrec = procrec ;
 212     }
 213     for ( i = 0 ; i < ntbl_id ; i++ )
 214     {
 215       if ( tbl_id[i] == id )
 216       {
 217         found = 1 ;
 218         break ;
 219       }
 220     }
 221     if ( found ) ptrec = tbl_ptrec[i] ;
 222 #endif
 223     if ( !found )       /* add it */
 224     {
 225       lp    = RSL_MALLOC( rsl_list_t, 1 ) ;
 226       ptrec = RSL_MALLOC( rsl_ptrec_t, 1 ) ;
 227       ptrec->pt = &(domain[INDEX_2(n,m,mlen)]) ;
 228       ptrec->ig = m ;
 229       ptrec->jg = n ;
 230       ptrec->nsendmsgs = 0 ;
 231       ptrec->nrecvmsgs = 0 ;
 232       ptrec->send_messages = NULL ;
 233       ptrec->recv_messages = NULL ;
 234       lp->data = ptrec ;
 235       lp->next = procrec->point_list ;
 236       procrec->point_list = lp ;
 237       procrec->npts++ ;
 238       send_accum += sizeof( rsl_point_hdr_t ) ;
 239 #ifdef NEC_TUNE
 240       if ( ntbl_id == ntbl_id_max || tbl_id == NULL )
 241       {
 242         ntbl_id_max *= 2 ;
 243         tbl_id = (rsl_point_id_t *)realloc((void *)tbl_id, ntbl_id_max*sizeof(rsl_point_id_t *)) ;
 244         tbl_ptrec = (rsl_ptrec_t **)realloc((void *)tbl_ptrec, ntbl_id_max*sizeof(rsl_ptrec_t *)) ;
 245       }
 246       tbl_id[ntbl_id] = id ;
 247       tbl_ptrec[ntbl_id] = ptrec ;
 248       ntbl_id++ ;
 249 #endif
 250     }
 251
 252 /* 2.1.1.1.1 */
 253     /* add the ghost point to the list of points from which we
 254        will receive messages */
 255     id = POINTID(d,hn,hm) ;
 256     found = 0 ;
 257     for ( lp = procrec->recv_point_list ; lp != NULL ; lp = lp->next )
 258     {
 259       recv_ptrec = (rsl_ptrec_t *)lp->data ;
 260       if ( recv_ptrec->pt->id == id )
 261       {
 262         found = 1 ;
 263         break ;
 264       }
 265     }
 266     if ( !found )       /* add it */
 267     {
 268       lp    = RSL_MALLOC( rsl_list_t, 1 ) ;
 269       recv_ptrec = RSL_MALLOC( rsl_ptrec_t, 1 ) ;
 270       recv_ptrec->pt = &(domain[INDEX_2(hn,hm,mlen)]) ;
 271       recv_ptrec->ig = hm ;
 272       recv_ptrec->jg = hn ;
 273       recv_ptrec->nsendmsgs = 0 ;
 274       recv_ptrec->nrecvmsgs = 0 ;
 275       recv_ptrec->send_messages = NULL ;
 276       recv_ptrec->recv_messages = NULL ;
 277       lp->data = recv_ptrec ;
 278       lp->next = procrec->recv_point_list ;
 279       procrec->recv_point_list = lp ;
 280       procrec->recv_npts++ ;
 281       recv_accum += sizeof( rsl_point_hdr_t ) ;
 282     }
 283
 284
 285 /* 1.1.1.1.2 */
 286     /* at this point ptrec points to a ptrec (for the local point) in the
 287        list for the non-local processor. */
 288     msg = sd->msgs[d][ pt-1 ] ;
 289     if ( msg != NULL )
 290     {
 291       /* iterate through message list for ptrec and add the message
 292          to be sent to the ghost point from this local point to the list
 293          for the local point if it isn't there */
 294       for ( lp = ptrec->send_messages, found = 0 ; lp != NULL ; lp = lp->next )
 295       {
 296         if ( msg == ( message_desc_t * )lp->data )
 297         {
 298           found = 1 ;
 299           break ;
 300         }
 301       }
 302       if ( !found )   /* add it */
 303       {
 304         lp = RSL_MALLOC( rsl_list_t, 1 ) ;
 305         lp->data = msg ;
 306         lp->next = ptrec->send_messages ;
 307         lp->info1 = pt ;                        /* index of stencil point */
 308         ptrec->send_messages = lp ;
 309         send_accum += message_size( msg ) ;
 310         send_accum += sizeof(int) ;             /* for send of stencil point index */
 311         ptrec->nsendmsgs++ ;
 312       }
 313     }
 314
 315 /* 2.1.1.1.2 */
 316     /* repeat for the receives, but note, that for the receives we
 317        are only interested in the size of the messages. Also, we're
 318        interested in the ghost-point, not the point.*/
 319     msg = sd->msgs[d][ ipt-1 ] ;     /* ipt instead of pt used for index */
 320     if ( msg != NULL )
 321     {
 322       /* iterate through message list for recv_ptrec and if message to be
 323          received is not there add it. */
 324       for ( lp = recv_ptrec->recv_messages, found = 0 ;
 325                                       lp != NULL ; lp = lp->next )
 326       {
 327         if ( msg == ( message_desc_t * )lp->data )
 328         {
 329           found = 1 ;
 330           break ;
 331         }
 332       }
 333       if ( !found )
 334       {
 335         lp = RSL_MALLOC( rsl_list_t, 1 ) ;
 336         lp->data = msg ;
 337         lp->next = recv_ptrec->recv_messages ;
 338         lp->info2 = ipt ;               /* inverse stencil point */
 339         recv_ptrec->recv_messages = lp ;
 340         recv_accum += message_size( msg ) ;
 341         recv_accum += sizeof(int) ;             /* for send of stencil point index */
 342         recv_ptrec->nrecvmsgs++ ;
 343         ptrec->nrecvmsgs = recv_ptrec->nrecvmsgs ;   /* intentional (ptrec) */
 344       }
 345     }
 346   }
 347 }
 348
 349 check_sten ( s_p )
 350   int_p s_p ;
 351 {
 352   int s ;
 353
 354   s = *s_p ;
 355   RSL_TEST_ERR( s <= 0 || s > RSL_MAXDESCRIPTORS,
 356         "rsl_compile_stencil: bad stencil descriptor" ) ;
 357   RSL_TEST_ERR((sd = (stencil_desc_t *)sh_descriptors[s]) == NULL,
 358         "compile_descriptor: null stencil descriptor" ) ;
 359 fprintf(stderr,"DEBUG CHECK_STEN: s %d, sd->tag %d\n", s, sd->tag ) ;
 360   RSL_TEST_ERR( sd->tag != STENCIL_DESC,
 361         "compile_descriptor: bad stencil descriptor" ) ;
 362 }
 363
 364 /* this is now used internally only -- this will be called automatically
 365    whenever a stencil exchange is attempted on a stencil that has not
 366    yet been compiled */
 367 rsl_compile_stencil( d_p, s_p )
 368   int_p d_p, s_p ;
 369 {
 370   int d, s ;
 371   int i, j, k ;
 372   int len_plist ;
 373   int (*ptfcn)() ;
 374   rsl_list_t *lp, *lp2, *destr, *destr2, *ghost_points ;
 375   rsl_domain_info_t *dp ;
 376   rsl_point_t  *pt ;
 377   rsl_dimlen_t mlen, nlen ;
 378   int m, n ;
 379   rsl_processor_t P, Plist[RSL_MAXPROC] ;
 380   int check_local_pts() ;
 381
 382   d = *d_p ;
 383   s = *s_p ;
 384
 385   RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
 386           "rsl_compile_stencil: bad domain descriptor" ) ;
 387   RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
 388         "rsl_compile_stencil: descriptor for invalid domain" ) ;
 389
 390   mlen = domain_info[d].len_m ;
 391   nlen = domain_info[d].len_n ;
 392
 393   /* sd is static so that check_local_pts can get at it */
 394   RSL_TEST_ERR( s <= 0 || s > RSL_MAXDESCRIPTORS,
 395         "rsl_compile_stencil: bad stencil descriptor" ) ;
 396   RSL_TEST_ERR((sd = (stencil_desc_t *)sh_descriptors[s]) == NULL,
 397         "compile_descriptor: null stencil descriptor" ) ;
 398   RSL_TEST_ERR( sd->tag != STENCIL_DESC,
 399         "compile_descriptor: bad stencil descriptor" ) ;
 400   RSL_TEST_ERR( sd->compiled[d] != 0,
 401         "compile_stencil: stencil has already been compiled for this domain") ;
 402
 403   sd->compiled[d] = 1 ;
 404   ptfcn = sd->f[d].ptfcn ;
 405   dp = &(domain_info[d]) ;
 406
 407   if ( dp->decomposed != 1 )
 408   {
 409     default_decomposition( d_p,
 410                            &(domain_info[*d_p].loc_m),
 411                            &(domain_info[*d_p].loc_n) ) ;
 412   }
 413   /* get a list of the processors that have ghost points and store in
 414      Plist; len_plist is the number of processors stored */
 415   for ( i = 0 ; i < RSL_MAXPROC ; i++ )
 416     Plist[i] = 0 ;
 417   for ( lp = dp->ghost_pts ; lp != NULL ; lp = lp->next )
 418   {
 419     idx_ = ((rsl_point_t *)lp->data)->P ;
 420     if ( idx_ < 0 || idx_ >= RSL_MAXPROC )
 421     {
 422       sprintf(mess,"domain %d: idx_ = %d\n",d, idx_ );
 423       RSL_TEST_WRN(1,mess) ;
 424     }
 425     Plist[ idx_ ] = 1 ;
 426   }
 427   for ( len_plist = 0, i = 0 ; i < RSL_MAXPROC ; i++ )
 428     if ( Plist[i] == 1 ) Plist[ len_plist++ ] = i ;
 429
 430   for ( k = 0 ; k < len_plist ; k++ )
 431   {
 432     P = Plist[k] ;
 433
 434     procrec = RSL_MALLOC( rsl_procrec_t, 1 ) ;
 435     procrec->P = P ;
 436     procrec->next = sd->procs[d] ;
 437     sd->procs[d] = procrec ;
 438
 439 #if 0
 440     destroy_list( &recv_point_list, dstry_ptrec_list ) ;
 441     recv_point_list = NULL ;
 442 #endif
 443
 444 /* 1.1 */
 445     /* for every ghost point from P, mark any local point that lies
 446        on its stencil (using the point function associated with the
 447        stencil.   */
 448     procrec->npts = 0 ;
 449     procrec->recv_npts = 0 ;
 450     send_accum = 0 ;
 451     recv_accum = 0 ;
 452     for ( n = 0 ; n < nlen ; n++ )
 453       for ( m = 0 ; m < mlen ; m++ )
 454         if ( dp->domain[ INDEX_2( n, m, mlen ) ].P == P )
 455         {
 456 /* 1.1.1 */
 457            (*ptfcn)( d, m, mlen, n, nlen, check_local_pts ) ;
 458         }
 459
 460     procrec->nsends = 0 ;
 461     procrec->nrecvs = 0 ;
 462     procrec->sendsize = send_accum + sizeof(int) ; /* extra word for count */
 463     procrec->recvsize = recv_accum + sizeof(int) ; /* extra word for count */
 464   }
 465 #define NEW
 466 #ifdef NEW
 467   {
 468     int ig, jg, i, j ;
 469     rsl_list_t *lp1 ;
 470     void * base ;
 471     int elemsz, t0, t1, pack_table_size ;
 472     stencil_desc_t * sten ;
 473     rsl_ptrec_t * ptrec ;
 474     message_desc_t * msg ;
 475     rsl_fldspec_t * fld ;
 476
 477     sten = (stencil_desc_t *) sh_descriptors[ s ] ;
 478     for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
 479     {
 480       init_process_refs() ;
 481       for ( lp = procrec->point_list ; lp != NULL ; lp = lp->next )
 482       {
 483         ptrec = (rsl_ptrec_t *) lp->data ;
 484         ig = ptrec->ig ;
 485         jg = ptrec->jg ;
 486         i = ig - domain_info[d].ilocaloffset ;
 487         j = jg - domain_info[d].jlocaloffset ;
 488
 489         for ( lp1 = ptrec->send_messages ; lp1 != NULL ; lp1 = lp1->next )
 490         {
 491           msg = (message_desc_t *) lp1->data ;
 492           for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
 493           {
 494             if ( fld->type >= 100 ) sten->has_f90_fields = 1 ;
 495             base = fld->base ;
 496             elemsz = fld->elemsz ;
 497             switch (fld->strategy)
 498             {
 499             case MINNS_MAJEW_2D :               /* <MM> eg: psa(i,j) */
 500               t0 = fld->llen[0] ;
 501               store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz, 1, elemsz) ;
 502               break ;
 503             case MINEW_MAJNS_2D :               /* xxx(j,i) */
 504               t0 = fld->llen[0] ;
 505               store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz, 1, elemsz) ;
 506               break ;
 507             case MINNS_MAJEW_K_3D :             /* <MM> eg: ua(i,j,k) */
 508               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 509               store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz,
 510                                          fld->llen[2],
 511                                          t1*elemsz) ;
 512               break ;
 513             case MINEW_MAJNS_K_3D :             /* <MM> eg: u(j,i,k) */
 514               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 515               store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz,
 516                                          fld->llen[2],
 517                                          t1*elemsz) ;
 518               break ;
 519             case K_MIDNS_MAJEW_3D :             /* <MM> eg: u(k,i,j) */
 520               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 521               store_process_refs( base, fld->f90_table_index, (i*t0+j*t1)*elemsz, elemsz * t0, 1, elemsz) ;
 522               break ;
 523             case MINNS_K_MAJEW_3D :             /* <MM> eg: u(i,k,j) */
 524               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 525               store_process_refs( base, fld->f90_table_index, (i+j*t1)*elemsz, elemsz, fld->llen[1], t0*elemsz) ;
 526               break ;
 527             default:
 528               RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
 529               break ;
 530             }
 531           }
 532         }
 533       }
 534       process_refs( &(procrec->pack_table),
 535                     &(procrec->pack_table_size),
 536                     &(procrec->pack_table_nbytes), 1 ) ;
 537 #if 0
 538       fprintf(stderr,"pack P = %3d:\n",procrec->P ) ;
 539       show_pack_table( procrec->pack_table,
 540                        procrec->pack_table_size,
 541                        procrec->pack_table_nbytes ) ;
 542 #endif
 543     }
 544   }
 545   {
 546     int ig, jg, i, j ;
 547     rsl_list_t *lp1 ;
 548     void * base ;
 549     int elemsz, t0, t1, pack_table_size ;
 550     stencil_desc_t * sten ;
 551     rsl_ptrec_t * ptrec ;
 552     message_desc_t * msg ;
 553     rsl_fldspec_t * fld ;
 554
 555     sten = (stencil_desc_t *) sh_descriptors[ s ] ;
 556     for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
 557     {
 558       init_process_refs() ;
 559       for ( lp = procrec->recv_point_list ; lp != NULL ; lp = lp->next )
 560       {
 561         ptrec = (rsl_ptrec_t *) lp->data ;
 562         ig = ptrec->ig ;
 563         jg = ptrec->jg ;
 564         i = ig - domain_info[d].ilocaloffset ;
 565         j = jg - domain_info[d].jlocaloffset ;
 566
 567         for ( lp1 = ptrec->recv_messages ; lp1 != NULL ; lp1 = lp1->next )
 568         {
 569           msg = (message_desc_t *) lp1->data ;
 570           for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
 571           {
 572             if ( fld->type >= 100 ) sten->has_f90_fields = 1 ;
 573             base = fld->base ;
 574             elemsz = fld->elemsz ;
 575             switch (fld->strategy)
 576             {
 577             case MINNS_MAJEW_2D :               /* <MM> eg: psa(i,j) */
 578               t0 = fld->llen[0] ;
 579               store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz, 1, elemsz) ;
 580               break ;
 581             case MINEW_MAJNS_2D :               /* xxx(j,i) */
 582               t0 = fld->llen[0] ;
 583               store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz, 1, elemsz) ;
 584               break ;
 585             case MINNS_MAJEW_K_3D :             /* <MM> eg: ua(i,j,k) */
 586               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 587               store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz,
 588                                          fld->llen[2],
 589                                          t1*elemsz) ;
 590               break ;
 591             case MINEW_MAJNS_K_3D :             /* <MM> eg: u(j,i,k) */
 592               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 593               store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz,
 594                                          fld->llen[2],
 595                                          t1*elemsz) ;
 596               break ;
 597             case K_MIDNS_MAJEW_3D :             /* <MM> eg: u(k,i,j) */
 598               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 599               store_process_refs( base, fld->f90_table_index, (i*t0+j*t1)*elemsz, elemsz * t0, 1, elemsz) ;
 600               break ;
 601             case MINNS_K_MAJEW_3D :             /* <MM> eg: u(i,k,j) */
 602               t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
 603               store_process_refs( base, fld->f90_table_index, (i+j*t1)*elemsz, elemsz, fld->llen[1], t0*elemsz) ;
 604               break ;
 605             default:
 606               RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
 607               break ;
 608             }
 609           }
 610         }
 611       }
 612       process_refs( &(procrec->unpack_table),
 613                     &(procrec->unpack_table_size),
 614                     &(procrec->unpack_table_nbytes), 1 ) ;
 615 #if 0
 616       fprintf(stderr,"upack P = %3d:\n",procrec->P ) ;
 617       show_pack_table( procrec->unpack_table,
 618                        procrec->unpack_table_size,
 619                        procrec->unpack_table_nbytes ) ;
 620 #endif
 621     }
 622   }
 623 #endif
 624 }
 625
 626 show_pack_table( pack_table, pack_table_size, pack_table_nbytes )
 627   packrec_t pack_table[] ;
 628   int pack_table_size ;
 629   int pack_table_nbytes ;
 630 {
 631   int i,ii,jj ;
 632   for ( i = 0 ; i < pack_table_size ; i++ )
 633   {
 634     fprintf(stderr,
 635 "  base %08x %12d offset %10d f90 index %d n %3d nelem %5d stride %5d valid %2d\n",
 636               pack_table[i].base,
 637               pack_table[i].base,
 638               pack_table[i].offset,
 639               pack_table[i].f90_table_index,
 640               pack_table[i].n,
 641               pack_table[i].nelems,
 642               pack_table[i].stride,
 643               pack_table[i].valid ) ;
 644 #if 0
 645     for ( jj = 0 ; jj < pack_table[i].nelems ; jj++ )
 646     for ( ii = 0 ; ii < pack_table[i].n ; ii += 4 )
 647     {
 648       fprintf(stderr,"** elem %d, n %d, %16lx, %f\n",jj,ii,
 649                 (float *)( (char *)
 650                    pack_table[i].base +
 651                    pack_table[i].offset +
 652                    jj * pack_table[i].stride +
 653                    ii ),
 654                 *((float *)( (char *)
 655                    pack_table[i].base +
 656                    pack_table[i].offset +
 657                    jj * pack_table[i].stride +
 658                    ii ))
 659                    ) ;
 660     }
 661 #endif
 662
 663   }
 664   fprintf(stderr," table nbytes=%d\n", pack_table_nbytes ) ;
 665 }
 666
 667
 668 /*@
 669   SHOW_STEN_DIAGS - Show run time information about stencil performance.
 670
 671   Input parameter:
 672 . d - domain descriptor
 673 . s - stencil descriptor
 674
 675   Synopsis:
 676   subroutine SHOW_STEN_DIAGS ( d, s )
 677   integer d
 678   integer s
 679
 680   Notes:
 681   Information is sent to a file sten_diags_<pid> for each
 682   processor.
 683
 684   See also:
 685   RSL_CREATE_STENCIL, RSL_DESCRIBE_STENCIL, RSL_EXCH_STENCIL
 686
 687 @*/
 688
 689 static int show_sten_diags_first = 1 ;
 690
 691 SHOW_STEN_DIAGS ( d_p, s_p )
 692   int_p d_p, s_p ;
 693 {
 694   int d, s, P, nsends, nbytes ;
 695   stencil_desc_t *sp ;
 696   rsl_procrec_t *procrec ;
 697   rsl_ptrec_t *ptrec ;
 698   FILE *fp ;
 699   char fname[80], *code  ;
 700   int smsgs, rmsgs ;
 701   rsl_list_t *lp ;
 702
 703   s = *s_p ;
 704   d = *d_p ;
 705   RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
 706                             "show_sten_diags: bad domain descriptor") ;
 707   RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
 708                 "show_sten_diags: invalid domain descriptor" ) ;
 709   sp = (stencil_desc_t *)sh_descriptors[s] ;
 710   if ( sp == NULL ) return ;
 711   if ( show_sten_diags_first )
 712   {
 713     code = "w" ;
 714     show_sten_diags_first = 0 ;
 715   }
 716   else
 717   {
 718     code = "a" ;
 719   }
 720   sprintf(fname,"sten_diags_%04d",rsl_myproc) ;
 721   if (( fp = fopen ( fname, code )) == NULL )
 722   {
 723      perror(fname) ;
 724      exit(2) ;
 725   }
 726   fprintf(fp,"Diagnostics for stencil %3d, domain %3d\n",s,d) ;
 727
 728   for ( procrec = sp->procs[d] ; procrec != NULL ; procrec = procrec->next )
 729   {
 730     smsgs = 0 ; rmsgs = 0 ;
 731     for ( lp = procrec->point_list ; lp != NULL ; lp = lp->next )
 732     {
 733       ptrec = (rsl_ptrec_t *) lp->data ;
 734       smsgs += ptrec->nsendmsgs ;
 735       rmsgs += ptrec->nrecvmsgs ;
 736     }
 737     fprintf(fp,"   to %4d : %5d of %10d bytes (%10d tot), pts %4d, msgs %4d\n",
 738             procrec->P,
 739             procrec->nsends,
 740             procrec->sendsize,
 741             procrec->nsends*procrec->sendsize,
 742             procrec->npts,
 743             smsgs ) ;
 744     fprintf(fp," from %4d : %5d of %10d bytes (%10d tot), pts %4d, msgs %4d\n",
 745             procrec->P,
 746             procrec->nrecvs,
 747             procrec->recvsize,
 748             procrec->nrecvs*procrec->recvsize,
 749             procrec->recv_npts,
 750             rmsgs ) ;
 751   }
 752   fclose(fp) ;
 753 }
 754
 755 static FILE * fp = NULL ;
 756 static int show_first = 1 ;
 757 SHOW_MESSAGE ( mh_p )
 758   int_p mh_p ;
 759 {
 760   int mh ;
 761   message_desc_t *msg ;
 762   rsl_fldspec_t  *fld ;
 763   int dim ;
 764   char * code ;
 765   char fname[80] ;
 766
 767   mh = *mh_p ;
 768   if ( show_first )
 769   {
 770     code = "w" ;
 771     show_first = 0 ;
 772     sprintf(fname,"show_def_%04d",rsl_myproc) ;
 773     if (( fp = fopen ( fname, code )) == NULL )
 774     {
 775        perror(fname) ;
 776        exit(2) ;
 777     }
 778   }
 779   if ( mh == RSL_INVALID )
 780   {
 781     fprintf(fp,"MESSAGE HANDLE: RSL_INVALID\n" ) ;
 782   }
 783   else
 784   {
 785     msg = (message_desc_t *)mh_descriptors[mh] ;
 786     show_message_desc( msg ) ;
 787   }
 788 }
 789
 790 show_message_desc( msg )
 791   message_desc_t * msg ;
 792 {
 793   rsl_fldspec_t  *fld ;
 794   int dim ;
 795   int mh ;
 796
 797   if ( msg == NULL ) return ;
 798   fprintf(fp,"MESSAGE HANDLE: %d\n",msg->mh ) ;
 799   fprintf(fp,"           tag: %d\n",msg->tag ) ;
 800   fprintf(fp,"         nflds: %d\n",msg->nflds ) ;
 801   for ( fld = msg->fldspecs ; fld != NULL ; fld=fld->next )
 802   {
 803     fprintf(fp,"  FLD:\n") ;
 804     fprintf(fp,"          base: %x\n",fld->base ) ;
 805     fprintf(fp,"          ndim: %d\n",fld->ndim ) ;
 806     fprintf(fp,"        elemsz: %d\n",fld->elemsz ) ;
 807     for ( dim = 0 ; dim < fld->ndim && dim < RSL_MAXDIM ; dim++ )
 808     {
 809       fprintf(fp,"       decomp[%3d]: %d\n",dim,fld->decomp[dim] ) ;
 810       fprintf(fp,"         gdex[%3d]: %d\n",dim,fld->gdex[dim] ) ;
 811       fprintf(fp,"         glen[%3d]: %d\n",dim,fld->glen[dim] ) ;
 812       fprintf(fp,"         llen[%3d]: %d\n",dim,fld->llen[dim] ) ;
 813     }
 814   }
 815 }
 816
 817 /*@
 818   SHOW_STENCIL - Show information about the stencil structure
 819
 820   Input parameter:
 821 . s - domain descriptor
 822
 823   Synopsis:
 824   subroutine SHOW_STENCIL ( s )
 825   integer s
 826
 827   Notes:
 828   Information is sent to a file show_def_<pid> for each
 829   processor.
 830
 831   See also:
 832   RSL_CREATE_STENCIL, RSL_DESCRIBE_STENCIL
 833
 834 @*/
 835
 836 SHOW_STENCIL ( d_p, sh_p )
 837   int_p d_p ;
 838   int_p sh_p ;
 839 {
 840   int sh, d ;
 841   int spt ;
 842   stencil_desc_t * sten ;
 843   char * code ;
 844   char fname[80] ;
 845
 846   d  = *d_p ;
 847   sh = *sh_p ;
 848   if ( show_first )
 849   {
 850     code = "w" ;
 851     show_first = 0 ;
 852     sprintf(fname,"show_def_%04d",rsl_myproc) ;
 853     if (( fp = fopen ( fname, code )) == NULL )
 854     {
 855        perror(fname) ;
 856        exit(2) ;
 857     }
 858   }
 859   sten = (stencil_desc_t *)sh_descriptors[sh] ;
 860   if ( sten == NULL ) return ;
 861   fprintf(fp,"STENCIL HANDLE: %d\n",sh ) ;
 862   fprintf(fp,"           tag: %d\n",sten->tag ) ;
 863   fprintf(fp,"          npts: %d\n",sten->npts[d] ) ;
 864   fprintf(fp,"        maskid: %d\n",sten->maskid[d] ) ;
 865
 866   for ( spt = 0 ; spt < sten->npts[d] && spt < RSL_MAXSTEN+1 ; spt++ )
 867   {
 868     fprintf(fp,"    stencil pt: %d\n",spt ) ;
 869     show_message_desc( sten->msgs[d][spt] ) ;
 870   }
 871
 872   /* code to show processor lists not here yet */
 873
 874 }
 875