wrfv2_fire/external/RSL/RSL/pack_message.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 #define INTXFER
  58 #include <stdio.h>
  59 #include <stdlib.h>
  60 #include "rsl.h"
  61
  62 #define FWD(A,B,C)      my_bcopy(A,B,C)
  63 #define BWD(A,B,C)      my_bcopy(B,A,C)
  64
  65 extern int debuggal_pack ;
  66
  67 static int first_1 = 1 ;
  68 static int first_2 = 1 ;
  69
  70 static FILE * xfp = NULL ;
  71
  72 pack_message( msg, buf, cursor_p, d, ig, jg)
  73   message_desc_t *msg  ;
  74   char * buf ;
  75   int * cursor_p ;
  76   rsl_index_t d, ig, jg;
  77 {
  78   rsl_fldspec_t *fld ;
  79   int stride ;
  80   register int *ips, *ipd ;
  81   char * dd, * ss ;
  82   unsigned int i, j, k, elemsz, t0, t1, t2, t3 ;
  83   char * base ;
  84   int cursor ;
  85
  86   cursor = *cursor_p ;
  87
  88 #if 0
  89 if ( xfp == NULL )
  90 {
  91   sprintf(mess,"xfp.%03d",rsl_myproc);
  92   if(( xfp = fopen(mess,"w")) == NULL ) perror(mess)  ;
  93 }
  94 #endif
  95
  96   if ( msg == NULL ) return(-1) ;
  97
  98   i = ig - domain_info[d].ilocaloffset ;        /* this must not go neg */
  99   j = jg - domain_info[d].jlocaloffset ;        /* this must not go neg */
 100
 101 #if 0
 102   if ( debuggal_pack )
 103   {
 104     fprintf(stderr,"pack_message: %16x, d %d i %d,j %d,ig %d,jg %d, ioff %d, joff %d\n",
 105     msg->fldspecs->base, d, i,j,ig,jg,domain_info[d].ilocaloffset,domain_info[d].jlocaloffset ) ;
 106     if ( first_2 == 1 )
 107     {
 108       first_2 = 0 ;
 109       for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
 110       {
 111         base = fld->base ;
 112         fprintf(stderr,"  : %16x\n",base) ;
 113       }
 114     }
 115     fflush(stderr) ;
 116   }
 117 #endif
 118
 119   for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
 120   {
 121     elemsz = fld->elemsz ;
 122     if ( fld->type >= 100 )
 123     {
 124       base = (void *)get_base_for_index( fld->f90_table_index ) ;
 125     }
 126     else
 127     {
 128       base = fld->base ;
 129     }
 130     switch (fld->strategy)
 131     {
 132     case MINNS_MAJEW_2D :               /* <MM> eg: psa(i,j) */
 133       t0 = fld->llen[0] ;
 134       FWD( base+(i+j*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
 135       break ;
 136     case MINEW_MAJNS_2D :               /*      eg: xxx(j,i) */
 137       t0 = fld->llen[0] ;
 138       FWD( base+(j+i*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
 139       break ;
 140     case MINNS_MAJEW_K_3D :             /* <MM> eg: ua(i,j,k) */
 141       t0 = fld->llen[0] ;
 142       t1 = fld->llen[1]*t0 ;
 143       switch (elemsz)
 144       {
 145 #ifdef INTXFER
 146       case sizeof(int) :
 147         stride = t1 ;
 148         ipd = (int *)(&buf[cursor]) ;
 149         ips = (int *)(base + (i + j*t0)*elemsz) ;
 150         /* ipd must be aligned on 4 byte boundary on some machines
 151            for this to work -- a symptom of it not working would be
 152            a bus error, for example. */
 153         for ( k = 0 ; k < fld->llen[2] ; k++ )
 154         {
 155            *ipd = *ips ;
 156            ips += stride ;
 157            ipd ++ ;
 158         }
 159         cursor += fld->llen[2] * elemsz ;
 160         break ;
 161 #endif
 162       default :
 163         for( k = 0 ; k < fld->llen[2] ; k++ )
 164         {
 165           FWD( base+(i+j*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
 166           cursor+=elemsz ;
 167         }
 168         break ;
 169       }
 170       break ;
 171     case MINEW_MAJNS_K_3D :             /* <MM> eg: u(j,i,k) */
 172       t0 = fld->llen[0] ;
 173       t1 = fld->llen[1]*t0 ;
 174       switch (elemsz)
 175       {
 176 #ifdef INTXFER
 177       case sizeof(int) :
 178         stride = t1 ;
 179         ipd = (int *)(&buf[cursor]) ;
 180         ips = (int *)(base + (j + i*t0)*elemsz) ;
 181         /* ipd must be aligned on 4 byte boundary on some machines
 182            for this to work -- a symptom of it not working would be
 183            a bus error, for example. */
 184         for ( k = 0 ; k < fld->llen[2] ; k++ )
 185         {
 186            *ipd = *ips ;
 187            ips += stride ;
 188            ipd ++ ;
 189         }
 190         cursor += fld->llen[2] * elemsz ;
 191         break ;
 192 #endif
 193       default :
 194         for( k = 0 ; k < fld->llen[2] ; k++ )
 195         {
 196           FWD( base+(j+i*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
 197           cursor+=elemsz ;
 198         }
 199         break ;
 200       }
 201       break ;
 202
 203     case K_MIDNS_MAJEW_3D :             /* <MM> eg: u(k,i,j) */
 204       t0 = fld->llen[0] ;
 205       t1 = fld->llen[1]*t0 ;
 206       switch (elemsz)
 207       {
 208 #ifdef INTXFER
 209       case sizeof(int) :
 210         ipd = (int *)(&buf[cursor]) ;
 211         ips = (int *)(base + (i*t0+j*t1)*elemsz) ;
 212         /* ipd must be aligned on 4 byte boundary on some machines
 213            for this to work -- a symptom of it not working would be
 214            a bus error, for example. */
 215         for ( k = 0 ; k < t0 ; k++ )
 216         {
 217            *ipd++ = *ips++ ;
 218         }
 219         cursor += t0*elemsz ;
 220         break ;
 221 #endif
 222       default :
 223         FWD( base+(i*t0+j*t1)*elemsz,&(buf[cursor]),t0*elemsz ) ;
 224         cursor+=t0*elemsz ;
 225         break ;
 226       }
 227       break ;
 228
 229
 230     default:
 231       RSL_TEST_ERR(1,"pack_message: strategy not supported" ) ;
 232       break ;
 233     }
 234   }
 235   *cursor_p = cursor ;
 236 }
 237
 238 unpack_message( msg, buf, cursor_p, d, ig, jg)
 239   message_desc_t *msg  ;
 240   char * buf ;
 241   int * cursor_p ;
 242   rsl_index_t d, ig, jg;
 243 {
 244   rsl_fldspec_t *fld ;
 245   register int * ips, * ipd ;
 246   char * dd, * ss ;
 247   unsigned int i, j, k, elemsz, t0, t1, t2, t3 ;
 248   char * base ;
 249   int cursor ;
 250   int stride ;
 251
 252   cursor = *cursor_p ;
 253
 254 #if 0
 255 if ( xfp == NULL )
 256 {
 257   sprintf(mess,"xfp.%03d",rsl_myproc);
 258   xfp = fopen(mess,"w") ;
 259 }
 260 #endif
 261
 262
 263   if ( msg == NULL ) return(-1) ;
 264
 265   i = ig - domain_info[d].ilocaloffset ;        /* this must not go neg */
 266   j = jg - domain_info[d].jlocaloffset ;        /* this must not go neg */
 267
 268 #if 0
 269   if ( debuggal_pack )
 270   {
 271     fprintf(stderr,"unpack_message: %16x, i %d,j %d,ig %d,jg %d, ioff %d, joff %d\n",
 272     msg->fldspecs->base,i,j,ig,jg,domain_info[d].ilocaloffset,domain_info[d].jlocaloffset ) ;
 273     if ( first_1 == 1 )
 274     {
 275       first_1 = 0 ;
 276       for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
 277       {
 278         base = fld->base ;
 279         fprintf(stderr, "  : base=%16x, elemsz=%d, strategy=%d \n"
 280                            , base, fld->elemsz, fld->strategy
 281                ) ;
 282       }
 283     }
 284
 285     fflush(stderr) ;
 286   }
 287 #endif
 288
 289   for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
 290   {
 291     elemsz = fld->elemsz ;
 292     if ( fld->type >= 100 )
 293     {
 294       base = (void *)get_base_for_index( fld->f90_table_index ) ;
 295     }
 296     else
 297     {
 298       base = fld->base ;
 299     }
 300     switch (fld->strategy)
 301     {
 302     case MINNS_MAJEW_2D :               /* <MM> eg: psa(i,j) */
 303       t0 = fld->llen[0] ;
 304       BWD( base+(i+j*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
 305       break ;
 306     case MINEW_MAJNS_2D :               /*      eg: xxx(j,i) */
 307       t0 = fld->llen[0] ;
 308       BWD( base+(j+i*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
 309       break ;
 310     case MINNS_MAJEW_K_3D :             /* <MM> eg: ua(i,j,k) */
 311       t0 = fld->llen[0] ;
 312       t1 = fld->llen[1]*t0 ;
 313       switch (elemsz)
 314       {
 315 #ifdef INTXFER
 316       case sizeof(int) :
 317         stride = t1 ;
 318         ips = (int *)(&buf[cursor]) ;
 319         ipd = (int *)(base + (i + j*t0)*elemsz) ;
 320         /* ipd must be aligned on 4 byte boundary on some machines
 321            for this to work -- a symptom of it not working would be
 322            a bus error, for example. */
 323         for ( k = 0 ; k < fld->llen[2] ; k++ )
 324         {
 325            *ipd = *ips ;
 326            ips ++ ;
 327            ipd += stride ;
 328         }
 329         cursor += fld->llen[2] * elemsz ;
 330         break ;
 331 #endif
 332       default :
 333         for( k = 0 ; k < fld->llen[2] ; k++ )
 334         {
 335           BWD( base+(i+j*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
 336           cursor+=elemsz ;
 337         }
 338         break ;
 339       }
 340       break ;
 341     case MINEW_MAJNS_K_3D :             /* <MM> eg: u(j,i,k) */
 342       t0 = fld->llen[0] ;
 343       t1 = fld->llen[1]*t0 ;
 344       switch (elemsz)
 345       {
 346 #ifdef INTXFER
 347       case sizeof(int) :
 348         stride = t1 ;
 349         ips = (int *)(&buf[cursor]) ;
 350         ipd = (int *)(base + (j + i*t0)*elemsz) ;
 351         /* ipd must be aligned on 4 byte boundary on some machines
 352            for this to work -- a symptom of it not working would be
 353            a bus error, for example. */
 354         for ( k = 0 ; k < fld->llen[2] ; k++ )
 355         {
 356            *ipd = *ips ;
 357            ips ++ ;
 358            ipd += stride ;
 359         }
 360         cursor += fld->llen[2] * elemsz ;
 361         break ;
 362 #endif
 363       default :
 364         for( k = 0 ; k < fld->llen[2] ; k++ )
 365         {
 366           BWD( base+(j+i*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
 367           cursor+=elemsz ;
 368         }
 369         break ;
 370       }
 371       break ;
 372
 373     case K_MIDNS_MAJEW_3D :             /* <MM> eg: u(k,i,j) */
 374       t0 = fld->llen[0] ;
 375       t1 = fld->llen[1]*t0 ;
 376       switch (elemsz)
 377       {
 378 #ifdef INTXFER
 379       case sizeof(int) :
 380         ips = (int *)(&buf[cursor]) ;
 381         ipd = (int *)(base + (i*t0+j*t1)*elemsz) ;
 382         /* ipd must be aligned on 4 byte boundary on some machines
 383            for this to work -- a symptom of it not working would be
 384            a bus error, for example. */
 385         for ( k = 0 ; k < t0 ; k++ )
 386         {
 387            *ipd++ = *ips++ ;
 388         }
 389         cursor += t0*elemsz ;
 390         break ;
 391 #endif
 392       default :
 393         BWD( base+(i*t0+j*t1)*elemsz,&(buf[cursor]),t0*elemsz ) ;
 394         cursor+=t0*elemsz ;
 395         break ;
 396       }
 397       break ;
 398
 399     default:
 400       RSL_TEST_ERR(1,"unpack_message: strategy not supported" ) ;
 401       break ;
 402     }
 403   }
 404   *cursor_p = cursor ;
 405 }
 406
 407 my_bcopy( A, B, C )
 408   char * A ;
 409   char * B ;
 410   int C ;
 411 {
 412   int i ;
 413   for ( i = 0 ; i < C ; i++ ) *(B+i) = *(A+i) ;
 414 }
 415