external/RSL_LITE/c_code.c

   1 #ifndef MS_SUA_
   2 # include <stdio.h>
   3 #endif
   4 #include <fcntl.h>
   5 #ifndef O_CREAT
   6 # define O_CREAT _O_CREAT
   7 #endif
   8 #ifndef O_WRONLY
   9 # define O_WRONLY _O_WRONLY
  10 #endif
  11 #ifndef O_TRUNC
  12 # define O_TRUNC _O_TRUNC
  13 #endif
  14
  15 #ifdef _WIN32
  16 #include <Winsock2.h>
  17 #endif
  18 #ifdef NCEP_DEBUG_MULTIDIR
  19 // #  include <errno.h>
  20 #endif
  21
  22 #define STANDARD_ERROR 2
  23
  24 #define STANDARD_OUTPUT 1
  25
  26 #ifndef STUBMPI
  27 #  include "mpi.h"
  28 #endif
  29 #include "rsl_lite.h"
  30
  31 #define F_PACK
  32
  33 #define ORIG_RSL_CUTOFF 10000
  34
  35 void RSL_LITE_ERROR_DUP1 ( int *me , int *size )
  36 {
  37     int newfd,rc ;
  38     char filename[256] ;
  39     char dirname[256] ;
  40     char hostname[256] ;
  41
  42 /* redirect standard out and standard error based on compile options*/
  43
  44 #ifndef NCEP_DEBUG_MULTIDIR
  45     gethostname( hostname, 256 ) ;
  46
  47 /* redirect standard out*/
  48 # ifndef RSL0_ONLY
  49     if ( *size < ORIG_RSL_CUTOFF )
  50     {
  51       sprintf(filename,"rsl.out.%04d",*me) ;
  52     }
  53     else
  54     {
  55       sprintf(filename,"rsl.out.%08d",*me) ;
  56     }
  57 # else
  58     if (*me == 0)
  59     {
  60       if ( *size < ORIG_RSL_CUTOFF )
  61       {
  62         sprintf(filename,"rsl.out.%04d",*me) ;
  63       }
  64       else {
  65         sprintf(filename,"rsl.out.%08d",*me) ;
  66       }
  67     }
  68     else
  69     {
  70       sprintf(filename,"/dev/null") ;
  71     }
  72 # endif
  73     if ((newfd = open( filename, O_CREAT | O_WRONLY | O_TRUNC, 0666 )) < 0 )
  74     {
  75         perror("error_dup: cannot open rsl.out.nnnn") ;
  76         fprintf(stderr,"...sending output to standard output and continuing.\n") ;
  77         return ;
  78     }
  79     if( dup2( newfd, STANDARD_OUTPUT ) < 0 )
  80     {
  81         perror("error_dup: dup2 fails to change output descriptor") ;
  82         fprintf(stderr,"...sending output to standard output and continuing.\n") ;
  83         close(newfd) ;
  84         return ;
  85     }
  86
  87 /* redirect standard error */
  88 # if defined( _WIN32 )
  89     if ( *me != 0 ) {   /* stderr from task 0 should come to screen on windows because it is buffered if redirected */
  90 #endif
  91 # ifndef RSL0_ONLY
  92     if ( *size < ORIG_RSL_CUTOFF )
  93     {
  94       sprintf(filename,"rsl.error.%04d",*me) ;
  95     }
  96     else
  97     {
  98       sprintf(filename,"rsl.error.%08d",*me) ;
  99     }
 100 # else
 101     if (*me == 0)
 102     {
 103       if ( *size < ORIG_RSL_CUTOFF )
 104       {
 105         sprintf(filename,"rsl.error.%04d",*me) ;
 106       }
 107       else {
 108         sprintf(filename,"rsl.error.%08d",*me) ;
 109       }
 110     }
 111     else
 112     {
 113       sprintf(filename,"/dev/null") ;
 114     }
 115 # endif
 116     if ((newfd = open( filename, O_CREAT | O_WRONLY | O_TRUNC, 0666 )) < 0 )
 117     {
 118         perror("error_dup: cannot open rsl.error.log") ;
 119         fprintf(stderr,"...sending error to standard error and continuing.\n") ;
 120         return ;
 121     }
 122     if( dup2( newfd, STANDARD_ERROR ) < 0 )
 123     {
 124         perror("error_dup: dup2 fails to change error descriptor") ;
 125         fprintf(stderr,"...sending error to standard error and continuing.\n") ;
 126         close(newfd) ;
 127         return ;
 128     }
 129     fprintf( stdout, "taskid: %d hostname: %s\n",*me,hostname) ;
 130     fprintf( stderr, "taskid: %d hostname: %s\n",*me,hostname) ;
 131 # if defined( _WIN32 )
 132     }
 133 # endif
 134 #else
 135 # ifndef NCEP_DEBUG_GLOBALSTDOUT
 136
 137 /*create TASKOUTPUT directory to contain separate task owned output directories*/
 138
 139    /* let task 0 create the subdirectory path for the task directories */
 140
 141     if (*me == 0)
 142     {
 143         sprintf(dirname, "%s","TASKOUTPUT");
 144         rc = mkdir(dirname, 0777);
 145         if ( rc != 0 && errno==EEXIST) rc=0;
 146     }
 147
 148     /* If TASKOUTPUT directory is not created then return */
 149
 150     MPI_Bcast(&rc, 1, MPI_INTEGER, 0, MPI_COMM_WORLD);
 151
 152     if (rc != 0 ) {
 153        if (*me == 0 ) {
 154           perror("mkdir error");
 155           fprintf(stderr, "mkdir failed for directory %s on task %d. Sending error/output to stderr/stdout for all tasks and continuing.\n", dirname, *me);
 156           return;
 157        }
 158        else {
 159           return;
 160        }
 161     }
 162
 163     /* TASKOUTPUT directory exists, continue with task specific directory */
 164
 165     if ( *size < ORIG_RSL_CUTOFF )
 166     {
 167       sprintf(dirname, "TASKOUTPUT/%04d", *me);
 168     }
 169     else
 170     {
 171       sprintf(dirname, "TASKOUTPUT/%08d", *me);
 172     }
 173     rc=mkdir(dirname, 0777);
 174     if (  rc !=0 && errno!=EEXIST ) {
 175         perror("mkdir error");
 176         fprintf(stderr, "mkdir failed for directory %s on task %d. Sending error/output to stderr/stdout and continuing.\n", dirname, *me);
 177         return;
 178     }
 179
 180    /* Each tasks creates/opens its own output and error files */
 181
 182     if ( *size < ORIG_RSL_CUTOFF )
 183     {
 184       sprintf(filename, "%s/%04d/rsl.out.%04d","TASKOUTPUT",*me,*me) ;
 185     }
 186     else
 187     {
 188       sprintf(filename, "%s/%08d/rsl.out.%08d","TASKOUTPUT",*me,*me) ;
 189     }
 190
 191    if ((newfd = open( filename, O_CREAT | O_WRONLY | O_TRUNC, 0666 )) < 0 )
 192    {
 193         perror("error_dup: cannot open ./TASKOUTPUT/nnnn/rsl.out.nnnn") ;
 194         fprintf(stderr,"...sending output to standard output and continuing.\n")
 195  ;
 196         return ;
 197    }
 198    if( dup2( newfd, STANDARD_OUTPUT ) < 0 )
 199    {
 200         perror("error_dup: dup2 fails to change output descriptor") ;
 201         fprintf(stderr,"...sending output to standard output and continuing.\n");
 202         close(newfd) ;
 203         return ;
 204    }
 205
 206    if ( *size < ORIG_RSL_CUTOFF )
 207    {
 208      sprintf(filename, "%s/%04d/rsl.error.%04d","TASKOUTPUT",*me,*me) ;
 209    }
 210    else
 211    {
 212      sprintf(filename, "%s/%08d/rsl.error.%08d","TASKOUTPUT",*me,*me) ;
 213    }
 214    if ((newfd = open( filename, O_CREAT | O_WRONLY | O_TRUNC, 0666 )) < 0 )
 215    {
 216        perror("error_dup: cannot open ./TASKOUTPUT/nnnn/rsl.error.nnnn") ;
 217        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
 218        return ;
 219    }
 220    if( dup2( newfd, STANDARD_ERROR ) < 0 )
 221    {
 222        perror("error_dup: dup2 fails to change error descriptor") ;
 223        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
 224        close(newfd) ;
 225        return ;
 226    }
 227 # else
 228 /* Each task writes to global standard error and standard out */
 229
 230    return;
 231
 232 # endif
 233 #endif
 234 }
 235
 236 #ifdef _WIN32
 237 /* Windows doesn't have a gethostid function so add a stub.
 238    TODO: Create a version that will work on Windows. */
 239 int
 240 gethostid ()
 241 {
 242         return 0;
 243 }
 244 #endif
 245
 246 RSL_LITE_GET_HOSTNAME ( char * hn, int * size, int *n, int *hostid )
 247 {
 248    char temp[512] ;
 249    char *p, *q ;
 250    int i, cs ;
 251    if ( gethostname(temp,512) ) return(1) ;
 252    cs = gethostid() ;
 253    for ( p = temp , q = hn , i = 0 ; *p && i < *size && i < 512 ; i++ , p++ , q++ ) { *q = *p ; }
 254    *n = i ;
 255    *hostid = cs ;
 256    return(0) ;
 257 }
 258
 259 BYTE_BCAST ( char * buf, int * size, int * Fcomm )
 260 {
 261 #ifndef STUBMPI
 262     MPI_Comm *comm, dummy_comm ;
 263
 264     comm = &dummy_comm ;
 265     *comm = MPI_Comm_f2c( *Fcomm ) ;
 266 # ifdef crayx1
 267     if (*size % sizeof(int) == 0) {
 268        MPI_Bcast ( buf, *size/sizeof(int), MPI_INT, 0, *comm ) ;
 269     } else {
 270        MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
 271     }
 272 # else
 273     MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
 274 # endif
 275 #endif
 276 }
 277
 278 BYTE_BCAST_FROM_ROOT ( char * buf, int * size, int *root , int * Fcomm )
 279 {
 280 #ifndef STUBMPI
 281     MPI_Comm *comm, dummy_comm ;
 282
 283     comm = &dummy_comm ;
 284     *comm = MPI_Comm_f2c( *Fcomm ) ;
 285 # ifdef crayx1
 286     if (*size % sizeof(int) == 0) {
 287        MPI_Bcast ( buf, *size/sizeof(int), MPI_INT, *root, *comm ) ;
 288     } else {
 289        MPI_Bcast ( buf, *size, MPI_BYTE, *root, *comm ) ;
 290     }
 291 # else
 292     MPI_Bcast ( buf, *size, MPI_BYTE, *root, *comm ) ;
 293 # endif
 294 #endif
 295 }
 296
 297 static int yp_curs, ym_curs, xp_curs, xm_curs ;
 298 static int yp_curs_recv, ym_curs_recv, xp_curs_recv, xm_curs_recv ;
 299
 300 RSL_LITE_INIT_EXCH (
 301                 int * Fcomm0,
 302                 int * shw0,  int * xy0 ,
 303                 int *sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 ,
 304                 int *recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 ,
 305                 int * n3dR0, int *n2dR0, int * typesizeR0 ,
 306                 int * n3dI0, int *n2dI0, int * typesizeI0 ,
 307                 int * n3dD0, int *n2dD0, int * typesizeD0 ,
 308                 int * n3dL0, int *n2dL0, int * typesizeL0 ,
 309                 int * me0, int * np0 , int * np_x0 , int * np_y0 ,
 310                 int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
 311 {
 312   int n3dR, n2dR, typesizeR ;
 313   int n3dI, n2dI, typesizeI ;
 314   int n3dD, n2dD, typesizeD ;
 315   int n3dL, n2dL, typesizeL ;
 316   int shw ;
 317   int sendbegm , sendwm, sendbegp , sendwp ;
 318   int recvbegm , recvwm, recvbegp , recvwp ;
 319   int me, np, np_x, np_y ;
 320   int ips , ipe , jps , jpe , kps , kpe ;
 321   int xy ;
 322   int yp, ym, xp, xm ;
 323   int nbytes ;
 324   int nbytes_x_recv = 0, nbytes_y_recv = 0 ;
 325
 326 #ifndef STUBMPI
 327   MPI_Comm comm, *comm0, dummy_comm ;
 328
 329   comm0 = &dummy_comm ;
 330   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
 331
 332   shw = *shw0 ;          /* logical half-width of stencil */
 333   xy = *xy0 ;              /* 0 = y , 1 = x */
 334   sendbegm = *sendbegm0 ;  /* send index of sten copy (edge = 1), lower/left */
 335   sendwm   = *sendwm0   ;  /* send width of sten copy counting towards edge, lower/left */
 336   sendbegp = *sendbegp0 ;  /* send index of sten copy (edge = 1), upper/right */
 337   sendwp   = *sendwp0   ;  /* send width of sten copy counting towards edge, upper/right */
 338   recvbegm = *recvbegm0 ;  /* recv index of sten copy (edge = 1), lower/left */
 339   recvwm   = *recvwm0   ;  /* recv width of sten copy counting towards edge, lower/left */
 340   recvbegp = *recvbegp0 ;  /* recv index of sten copy (edge = 1), upper/right */
 341   recvwp   = *recvwp0   ;  /* recv width of sten copy counting towards edge, upper/right */
 342   n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
 343   n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
 344   n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
 345   n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
 346   me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
 347   ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
 348
 349   yp_curs_recv = 0 ; ym_curs_recv = 0 ;
 350   xp_curs_recv = 0 ; xm_curs_recv = 0 ;
 351
 352   if ( xy == 0 && np_y > 1 ) {
 353     nbytes = typesizeR*(ipe-ips+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
 354              typesizeI*(ipe-ips+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
 355              typesizeD*(ipe-ips+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
 356              typesizeL*(ipe-ips+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
 357     nbytes_y_recv =
 358              typesizeR*(ipe-ips+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
 359              typesizeI*(ipe-ips+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
 360              typesizeD*(ipe-ips+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
 361              typesizeL*(ipe-ips+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
 362     MPI_Cart_shift ( *comm0, 0, 1, &ym, &yp ) ;
 363     if ( yp != MPI_PROC_NULL ) {
 364        buffer_for_proc ( yp , nbytes_y_recv, RSL_RECVBUF ) ;
 365        buffer_for_proc ( yp , nbytes, RSL_SENDBUF ) ;
 366     }
 367     if ( ym != MPI_PROC_NULL ) {
 368        buffer_for_proc ( ym , nbytes_y_recv, RSL_RECVBUF ) ;
 369        buffer_for_proc ( ym , nbytes, RSL_SENDBUF ) ;
 370     }
 371   }
 372   if ( xy == 1 && np_x > 1 ) {
 373     nbytes = typesizeR*(jpe-jps+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
 374              typesizeI*(jpe-jps+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
 375              typesizeD*(jpe-jps+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
 376              typesizeL*(jpe-jps+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
 377     nbytes_x_recv =
 378              typesizeR*(jpe-jps+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
 379              typesizeI*(jpe-jps+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
 380              typesizeD*(jpe-jps+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
 381              typesizeL*(jpe-jps+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
 382     MPI_Cart_shift ( *comm0, 1, 1, &xm, &xp ) ;
 383     if ( xp != MPI_PROC_NULL ) {
 384        buffer_for_proc ( xp , nbytes_x_recv, RSL_RECVBUF ) ;
 385        buffer_for_proc ( xp , nbytes, RSL_SENDBUF ) ;
 386     }
 387     if ( xm != MPI_PROC_NULL ) {
 388        buffer_for_proc ( xm , nbytes_x_recv, RSL_RECVBUF ) ;
 389        buffer_for_proc ( xm , nbytes, RSL_SENDBUF ) ;
 390     }
 391   }
 392 #endif
 393   yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
 394   yp_curs_recv = nbytes_y_recv ; ym_curs_recv = nbytes_y_recv ;
 395   xp_curs_recv = nbytes_x_recv ; xm_curs_recv = nbytes_x_recv ;
 396 }
 397
 398 RSL_LITE_PACK ( int * Fcomm0, char * buf , int * shw0 ,
 399            int * sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 ,
 400            int * recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 ,
 401            int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * xstag0, /* not used */
 402            int *me0, int * np0 , int * np_x0 , int * np_y0 ,
 403            int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
 404            int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
 405            int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
 406 {
 407   int me, np, np_x, np_y ;
 408   int sendbegm , sendwm, sendbegp , sendwp ;
 409   int recvbegm , recvwm, recvbegp , recvwp ;
 410   int shw , typesize ;
 411   int ids , ide , jds , jde , kds , kde ;
 412   int ims , ime , jms , jme , kms , kme ;
 413   int ips , ipe , jps , jpe , kps , kpe ;
 414   int xy ;   /* y = 0 , x = 1 */
 415   int pu ;   /* pack = 0 , unpack = 1 */
 416   register int i, j, k, t ;
 417 #ifdef crayx1
 418   register int i2,i3,i4,i_offset;
 419 #endif
 420   char *p ;
 421   int da_buf ;
 422   int yp, ym, xp, xm ;
 423   int nbytes, ierr ;
 424   register int *pi, *qi ;
 425
 426 #ifndef STUBMPI
 427   MPI_Comm comm, *comm0, dummy_comm ;
 428   int js, je, ks, ke, is, ie, wcount ;
 429
 430   comm0 = &dummy_comm ;
 431   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
 432
 433   shw = *shw0 ;          /* logical half-width of stencil */
 434   sendbegm = *sendbegm0 ;  /* send index of sten copy (edge = 1), lower/left */
 435   sendwm   = *sendwm0   ;  /* send width of sten copy counting towards edge, lower/left */
 436   sendbegp = *sendbegp0 ;  /* send index of sten copy (edge = 1), upper/right */
 437   sendwp   = *sendwp0   ;  /* send width of sten copy counting towards edge, upper/right */
 438   recvbegm = *recvbegm0 ;  /* recv index of sten copy (edge = 1), lower/left */
 439   recvwm   = *recvwm0   ;  /* recv width of sten copy counting towards edge, lower/left */
 440   recvbegp = *recvbegp0 ;  /* recv index of sten copy (edge = 1), upper/right */
 441   recvwp   = *recvwp0   ;  /* recv width of sten copy counting towards edge, upper/right */
 442   me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
 443   typesize = *typesize0 ;
 444   ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
 445   ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
 446   ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
 447   xy = *xy0 ;
 448   pu = *pu0 ;
 449
 450 /* need to adapt for other memory orders */
 451
 452 #define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*((E3)-(S3)+1)*((E4)-(S4)+1))
 453 #define IMAX(A) (((A)>ids)?(A):ids)
 454 #define IMIN(A) (((A)<ide)?(A):ide)
 455 #define JMAX(A) (((A)>jds)?(A):jds)
 456 #define JMIN(A) (((A)<jde)?(A):jde)
 457
 458   da_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
 459
 460   if ( ips <= ipe && jps <= jpe ) {
 461
 462   if ( np_y > 1 && xy == 0 ) {
 463     MPI_Cart_shift( *comm0 , 0, 1, &ym, &yp ) ;
 464     if ( yp != MPI_PROC_NULL && jpe <= jde  && jde != jpe ) {
 465       p = buffer_for_proc( yp , 0 , da_buf ) ;
 466       if ( pu == 0 ) {
 467         if ( sendwp > 0 ) {
 468           je = jpe - sendbegp + 1 ; js = je - sendwp + 1 ;
 469           ks = kps           ; ke = kpe ;
 470           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 471           nbytes = buffer_size_for_proc( yp, da_buf ) ;
 472           if ( yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
 473 #ifndef MS_SUA
 474             fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack up, %d > %d\n",
 475                 yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
 476 #endif
 477             MPI_Abort(MPI_COMM_WORLD, 99) ;
 478           }
 479           if ( typesize == 8 ) {
 480             F_PACK_LINT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 481                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 482             yp_curs += wcount*typesize ;
 483           }
 484           else if ( typesize == 4 ) {
 485             F_PACK_INT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 486                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 487             yp_curs += wcount*typesize ;
 488           }
 489           else {
 490 #ifndef MS_SUA
 491             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 492 #endif
 493           }
 494         }
 495       } else {
 496         if ( recvwp > 0 ) {
 497           js = jpe+recvbegp         ; je = js + recvwp - 1 ;
 498           ks = kps           ; ke = kpe ;
 499           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 500           if ( typesize == 8 ) {
 501             F_UNPACK_LINT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 502                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 503             yp_curs += wcount*typesize ;
 504           }
 505           else if ( typesize == 4 ) {
 506             F_UNPACK_INT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 507                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 508             yp_curs += wcount*typesize ;
 509           }
 510           else {
 511 #ifndef MS_SUA
 512             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 513 #endif
 514           }
 515         }
 516       }
 517     }
 518     if ( ym != MPI_PROC_NULL && jps >= jds  && jps != jds ) {
 519       p = buffer_for_proc( ym , 0 , da_buf ) ;
 520       if ( pu == 0 ) {
 521         if ( sendwm > 0 ) {
 522           js = jps+sendbegm-1 ; je = js + sendwm -1 ;
 523           ks = kps           ; ke = kpe ;
 524           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 525           nbytes = buffer_size_for_proc( ym, da_buf ) ;
 526           if ( ym_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
 527 #ifndef  MS_SUA
 528             fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack dn, %d > %d\n",
 529                 ym_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
 530 #endif
 531             MPI_Abort(MPI_COMM_WORLD, 99) ;
 532           }
 533           if ( typesize == 8 ) {
 534             F_PACK_LINT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 535                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 536             ym_curs += wcount*typesize ;
 537           }
 538           else if ( typesize == 4 ) {
 539             F_PACK_INT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 540                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 541             ym_curs += wcount*typesize ;
 542           }
 543           else {
 544 #ifndef MS_SUA
 545             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 546 #endif
 547           }
 548         }
 549       } else {
 550         if ( recvwm > 0 ) {
 551           je = jps-recvbegm ; js = je - recvwm + 1 ;
 552           ks = kps           ; ke = kpe ;
 553           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 554           if ( typesize == 8 ) {
 555             F_UNPACK_LINT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 556                                                   &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 557             ym_curs += wcount*typesize ;
 558           }
 559           else if ( typesize == 4 ) {
 560             F_UNPACK_INT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 561                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 562             ym_curs += wcount*typesize ;
 563           }
 564           else {
 565 #ifndef MS_SUA
 566             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 567 #endif
 568           }
 569         }
 570       }
 571     }
 572   }
 573
 574   if ( np_x > 1 && xy == 1 ) {
 575     MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
 576     if ( xp != MPI_PROC_NULL  && ipe <= ide && ide != ipe ) {
 577       p = buffer_for_proc( xp , 0 , da_buf ) ;
 578       if ( pu == 0 ) {
 579         if ( sendwp > 0 ) {
 580           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 581           ks = kps           ; ke = kpe ;
 582           ie = ipe - sendbegp + 1 ; is = ie - sendwp + 1 ;
 583           nbytes = buffer_size_for_proc( xp, da_buf ) ;
 584           if ( xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ) > nbytes ) {
 585 #ifndef MS_SUA
 586             fprintf(stderr,"memory overwrite in rsl_lite_pack, X pack right, %d > %d\n",
 587                 xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ), nbytes ) ;
 588 #endif
 589             MPI_Abort(MPI_COMM_WORLD, 99) ;
 590           }
 591           if ( typesize == 8 ) {
 592             F_PACK_LINT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 593                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 594             xp_curs += wcount*typesize ;
 595           }
 596           else if ( typesize == 4 ) {
 597             F_PACK_INT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 598                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 599             xp_curs += wcount*typesize ;
 600           }
 601           else {
 602 #ifndef MS_SUA
 603             fprintf(stderr,"A internal error: %s %d\n",__FILE__,__LINE__) ;
 604 #endif
 605           }
 606         }
 607       } else {
 608         if ( recvwp > 0 ) {
 609           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 610           ks = kps           ; ke = kpe ;
 611           is = ipe+recvbegp  ; ie = is + recvwp - 1 ;
 612           if ( typesize == 8 ) {
 613             F_UNPACK_LINT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 614                                                   &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 615             xp_curs += wcount*typesize ;
 616           }
 617           else if ( typesize == 4 ) {
 618             F_UNPACK_INT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 619                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 620             xp_curs += wcount*typesize ;
 621           }
 622           else {
 623 #ifndef MS_SUA
 624             fprintf(stderr,"B internal error: %s %d\n",__FILE__,__LINE__) ;
 625             fprintf(stderr,"  stenbeg %d stenw  %d \n",is,ie) ;
 626             fprintf(stderr,"  is %d ie %d \n",is,ie) ;
 627 #endif
 628           }
 629         }
 630       }
 631     }
 632     if ( xm != MPI_PROC_NULL  && ips >= ids && ids != ips ) {
 633       p = buffer_for_proc( xm , 0 , da_buf ) ;
 634       if ( pu == 0 ) {
 635         if ( sendwm > 0 ) {
 636           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 637           ks = kps           ; ke = kpe ;
 638           is = ips+sendbegm-1 ; ie = is + sendwm-1 ;
 639           nbytes = buffer_size_for_proc( xm, da_buf ) ;
 640           if ( xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ) > nbytes ) {
 641 #ifndef MS_SUA
 642             fprintf(stderr,"memory overwrite in rsl_lite_pack, X left , %d > %d\n",
 643                 xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ), nbytes ) ;
 644 #endif
 645             MPI_Abort(MPI_COMM_WORLD, 99) ;
 646           }
 647           if ( typesize == 8 ) {
 648             F_PACK_LINT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 649                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 650             xm_curs += wcount*typesize ;
 651           }
 652           else if ( typesize == 4 ) {
 653             F_PACK_INT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 654                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 655             xm_curs += wcount*typesize ;
 656           }
 657           else {
 658 #ifndef MS_SUA
 659             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 660 #endif
 661           }
 662         }
 663       } else {
 664         if ( recvwm > 0 ) {
 665           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 666           ks = kps           ; ke = kpe ;
 667           ie = ips-recvbegm ; is = ie - recvwm + 1 ;
 668           if ( typesize == 8 ) {
 669             F_UNPACK_LINT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 670                                                   &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 671             xm_curs += wcount*typesize ;
 672           }
 673           else if ( typesize == 4 ) {
 674             F_UNPACK_INT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 675                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 676             xm_curs += wcount*typesize ;
 677           }
 678           else {
 679 #ifndef MS_SUA
 680             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 681 #endif
 682           }
 683         }
 684       }
 685     }
 686   }
 687   }
 688 #endif
 689
 690 }
 691
 692 #if ( WRFPLUS == 1 )
 693 RSL_LITE_PACK_AD ( int * Fcomm0, char * buf , int * shw0 ,
 694            int * sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 ,
 695            int * recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 ,
 696            int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * xstag0, /* not used */
 697            int *me0, int * np0 , int * np_x0 , int * np_y0 ,
 698            int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
 699            int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
 700            int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
 701 {
 702   int me, np, np_x, np_y ;
 703   int sendbegm , sendwm, sendbegp , sendwp ;
 704   int recvbegm , recvwm, recvbegp , recvwp ;
 705   int shw , typesize ;
 706   int ids , ide , jds , jde , kds , kde ;
 707   int ims , ime , jms , jme , kms , kme ;
 708   int ips , ipe , jps , jpe , kps , kpe ;
 709   int xy ;   /* y = 0 , x = 1 */
 710   int pu ;   /* pack = 0 , unpack = 1 */
 711   register int i, j, k, t ;
 712 #ifdef crayx1
 713   register int i2,i3,i4,i_offset;
 714 #endif
 715   char *p ;
 716   int da_buf ;
 717   int yp, ym, xp, xm ;
 718   int nbytes, ierr ;
 719   register int *pi, *qi ;
 720
 721 #ifndef STUBMPI
 722   MPI_Comm comm, *comm0, dummy_comm ;
 723   int js, je, ks, ke, is, ie, wcount ;
 724
 725   comm0 = &dummy_comm ;
 726   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
 727
 728   shw = *shw0 ;          /* logical half-width of stencil */
 729   sendbegm = *sendbegm0 ;  /* send index of sten copy (edge = 1), lower/left */
 730   sendwm   = *sendwm0   ;  /* send width of sten copy counting towards edge, lower/left */
 731   sendbegp = *sendbegp0 ;  /* send index of sten copy (edge = 1), upper/right */
 732   sendwp   = *sendwp0   ;  /* send width of sten copy counting towards edge, upper/right */
 733   recvbegm = *recvbegm0 ;  /* recv index of sten copy (edge = 1), lower/left */
 734   recvwm   = *recvwm0   ;  /* recv width of sten copy counting towards edge, lower/left */
 735   recvbegp = *recvbegp0 ;  /* recv index of sten copy (edge = 1), upper/right */
 736   recvwp   = *recvwp0   ;  /* recv width of sten copy counting towards edge, upper/right */
 737   me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
 738   typesize = *typesize0 ;
 739   ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
 740   ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
 741   ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
 742   xy = *xy0 ;
 743   pu = *pu0 ;
 744
 745 /* need to adapt for other memory orders */
 746
 747 #define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*((E3)-(S3)+1)*((E4)-(S4)+1))
 748 #define IMAX(A) (((A)>ids)?(A):ids)
 749 #define IMIN(A) (((A)<ide)?(A):ide)
 750 #define JMAX(A) (((A)>jds)?(A):jds)
 751 #define JMIN(A) (((A)<jde)?(A):jde)
 752
 753   da_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
 754
 755   if ( ips <= ipe && jps <= jpe ) {
 756
 757   if ( np_y > 1 && xy == 0 ) {
 758     MPI_Cart_shift( *comm0 , 0, 1, &ym, &yp ) ;
 759     if ( yp != MPI_PROC_NULL && jpe <= jde  && jde != jpe ) {
 760       p = buffer_for_proc( yp , 0 , da_buf ) ;
 761       if ( pu != 0 ) {
 762         if ( sendwp > 0 ) {
 763           je = jpe - sendbegp + 1 ; js = je - sendwp + 1 ;
 764           ks = kps           ; ke = kpe ;
 765           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 766           nbytes = buffer_size_for_proc( yp, da_buf ) ;
 767           if ( yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
 768 #ifndef MS_SUA
 769             fprintf(stderr,"memory overwrite in rsl_lite_pack_ad, Y pack up, %d > %d\n",
 770                 yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
 771 #endif
 772             MPI_Abort(MPI_COMM_WORLD, 99) ;
 773           }
 774           if ( typesize == 8 ) {
 775             F_UNPACK_LINT_AD ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 776                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 777             yp_curs += wcount*typesize ;
 778           }
 779           else if ( typesize == 4 ) {
 780             F_UNPACK_INT_AD ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 781                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 782             yp_curs += wcount*typesize ;
 783           }
 784           else {
 785 #ifndef MS_SUA
 786             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 787 #endif
 788           }
 789         }
 790       } else {
 791         if ( recvwp > 0 ) {
 792           js = jpe+recvbegp         ; je = js + recvwp - 1 ;
 793           ks = kps           ; ke = kpe ;
 794           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 795           if ( typesize == 8 ) {
 796             F_PACK_LINT_AD ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 797                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 798             yp_curs += wcount*typesize ;
 799           }
 800           else if ( typesize == 4 ) {
 801             F_PACK_INT_AD ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 802                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 803             yp_curs += wcount*typesize ;
 804           }
 805           else {
 806 #ifndef MS_SUA
 807             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 808 #endif
 809           }
 810         }
 811       }
 812     }
 813     if ( ym != MPI_PROC_NULL && jps >= jds  && jps != jds ) {
 814       p = buffer_for_proc( ym , 0 , da_buf ) ;
 815       if ( pu != 0 ) {
 816         if ( sendwm > 0 ) {
 817           js = jps+sendbegm-1 ; je = js + sendwm -1 ;
 818           ks = kps           ; ke = kpe ;
 819           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 820           nbytes = buffer_size_for_proc( ym, da_buf ) ;
 821           if ( ym_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
 822 #ifndef  MS_SUA
 823             fprintf(stderr,"memory overwrite in rsl_lite_pack_ad, Y pack dn, %d > %d\n",
 824                 ym_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
 825 #endif
 826             MPI_Abort(MPI_COMM_WORLD, 99) ;
 827           }
 828           if ( typesize == 8 ) {
 829             F_UNPACK_LINT_AD ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 830                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 831             ym_curs += wcount*typesize ;
 832           }
 833           else if ( typesize == 4 ) {
 834             F_UNPACK_INT_AD ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 835                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 836             ym_curs += wcount*typesize ;
 837           }
 838           else {
 839 #ifndef MS_SUA
 840             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 841 #endif
 842           }
 843         }
 844       } else {
 845         if ( recvwm > 0 ) {
 846           je = jps-recvbegm ; js = je - recvwm + 1 ;
 847           ks = kps           ; ke = kpe ;
 848           is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 849           if ( typesize == 8 ) {
 850             F_PACK_LINT_AD ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 851                                                   &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 852             ym_curs += wcount*typesize ;
 853           }
 854           else if ( typesize == 4 ) {
 855             F_PACK_INT_AD ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 856                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 857             ym_curs += wcount*typesize ;
 858           }
 859           else {
 860 #ifndef MS_SUA
 861             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 862 #endif
 863           }
 864         }
 865       }
 866     }
 867   }
 868
 869   if ( np_x > 1 && xy == 1 ) {
 870     MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
 871     if ( xp != MPI_PROC_NULL  && ipe <= ide && ide != ipe ) {
 872       p = buffer_for_proc( xp , 0 , da_buf ) ;
 873       if ( pu != 0 ) {
 874         if ( sendwp > 0 ) {
 875           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 876           ks = kps           ; ke = kpe ;
 877           ie = ipe - sendbegp + 1 ; is = ie - sendwp + 1 ;
 878           nbytes = buffer_size_for_proc( xp, da_buf ) ;
 879           if ( xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ) > nbytes ) {
 880 #ifndef MS_SUA
 881             fprintf(stderr,"memory overwrite in rsl_lite_pack, X pack right, %d > %d\n",
 882                 xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ), nbytes ) ;
 883 #endif
 884             MPI_Abort(MPI_COMM_WORLD, 99) ;
 885           }
 886           if ( typesize == 8 ) {
 887             F_UNPACK_LINT_AD ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 888                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 889             xp_curs += wcount*typesize ;
 890           }
 891           else if ( typesize == 4 ) {
 892             F_UNPACK_INT_AD ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 893                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 894             xp_curs += wcount*typesize ;
 895           }
 896           else {
 897 #ifndef MS_SUA
 898             fprintf(stderr,"A internal error: %s %d\n",__FILE__,__LINE__) ;
 899 #endif
 900           }
 901         }
 902       } else {
 903         if ( recvwp > 0 ) {
 904           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 905           ks = kps           ; ke = kpe ;
 906           is = ipe+recvbegp  ; ie = is + recvwp - 1 ;
 907           if ( typesize == 8 ) {
 908             F_PACK_LINT_AD ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 909                                                   &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 910             xp_curs += wcount*typesize ;
 911           }
 912           else if ( typesize == 4 ) {
 913             F_PACK_INT_AD ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 914                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 915             xp_curs += wcount*typesize ;
 916           }
 917           else {
 918 #ifndef MS_SUA
 919             fprintf(stderr,"B internal error: %s %d\n",__FILE__,__LINE__) ;
 920             fprintf(stderr,"  stenbeg %d stenw  %d \n",is,ie) ;
 921             fprintf(stderr,"  is %d ie %d \n",is,ie) ;
 922 #endif
 923           }
 924         }
 925       }
 926     }
 927     if ( xm != MPI_PROC_NULL  && ips >= ids && ids != ips ) {
 928       p = buffer_for_proc( xm , 0 , da_buf ) ;
 929       if ( pu != 0 ) {
 930         if ( sendwm > 0 ) {
 931           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 932           ks = kps           ; ke = kpe ;
 933           is = ips+sendbegm-1 ; ie = is + sendwm-1 ;
 934           nbytes = buffer_size_for_proc( xm, da_buf ) ;
 935           if ( xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ) > nbytes ) {
 936 #ifndef MS_SUA
 937             fprintf(stderr,"memory overwrite in rsl_lite_pack_ad, X left , %d > %d\n",
 938                 xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ), nbytes ) ;
 939 #endif
 940             MPI_Abort(MPI_COMM_WORLD, 99) ;
 941           }
 942           if ( typesize == 8 ) {
 943             F_UNPACK_LINT_AD ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 944                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 945             xm_curs += wcount*typesize ;
 946           }
 947           else if ( typesize == 4 ) {
 948             F_UNPACK_INT_AD ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 949                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 950             xm_curs += wcount*typesize ;
 951           }
 952           else {
 953 #ifndef MS_SUA
 954             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 955 #endif
 956           }
 957         }
 958       } else {
 959         if ( recvwm > 0 ) {
 960           js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 961           ks = kps           ; ke = kpe ;
 962           ie = ips-recvbegm ; is = ie - recvwm + 1 ;
 963           if ( typesize == 8 ) {
 964             F_PACK_LINT_AD ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 965                                                   &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 966             xm_curs += wcount*typesize ;
 967           }
 968           else if ( typesize == 4 ) {
 969             F_PACK_INT_AD ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 970                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 971             xm_curs += wcount*typesize ;
 972           }
 973           else {
 974 #ifndef MS_SUA
 975             fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 976 #endif
 977           }
 978         }
 979       }
 980     }
 981   }
 982   }
 983 #endif
 984
 985 }
 986 #endif
 987 #ifndef STUBMPI
 988 static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
 989 static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
 990 #endif
 991
 992 RSL_LITE_EXCH_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ,
 993                   int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p )
 994 {
 995   int me, np, np_x, np_y ;
 996   int yp, ym, xp, xm, ierr ;
 997 #ifndef STUBMPI
 998   MPI_Status stat ;
 999   MPI_Comm comm, *comm0, dummy_comm ;
1000
1001   comm0 = &dummy_comm ;
1002   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
1003   comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
1004   if ( np_y > 1 ) {
1005     MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
1006     if ( yp != MPI_PROC_NULL && *recvw_p > 0 ) {
1007       ierr=MPI_Irecv ( buffer_for_proc( yp, yp_curs_recv, RSL_RECVBUF ), yp_curs_recv, MPI_CHAR, yp, me, comm, &yp_recv ) ;
1008     }
1009     if ( ym != MPI_PROC_NULL && *recvw_m > 0 ) {
1010       ierr=MPI_Irecv ( buffer_for_proc( ym, ym_curs_recv, RSL_RECVBUF ), ym_curs_recv, MPI_CHAR, ym, me, comm, &ym_recv ) ;
1011     }
1012     if ( yp != MPI_PROC_NULL && *sendw_p > 0 ) {
1013       ierr=MPI_Isend ( buffer_for_proc( yp, 0,       RSL_SENDBUF ), yp_curs, MPI_CHAR, yp, yp, comm, &yp_send ) ;
1014     }
1015     if ( ym != MPI_PROC_NULL && *sendw_m > 0 ) {
1016       ierr=MPI_Isend ( buffer_for_proc( ym, 0,       RSL_SENDBUF ), ym_curs, MPI_CHAR, ym, ym, comm, &ym_send ) ;
1017     }
1018     if ( yp != MPI_PROC_NULL && *recvw_p > 0 ) {  MPI_Wait( &yp_recv, &stat ) ;  }
1019     if ( ym != MPI_PROC_NULL && *recvw_m > 0 ) {  MPI_Wait( &ym_recv, &stat ) ;  }
1020     if ( yp != MPI_PROC_NULL && *sendw_p > 0 ) {  MPI_Wait( &yp_send, &stat ) ;  }
1021     if ( ym != MPI_PROC_NULL && *sendw_m > 0 ) {  MPI_Wait( &ym_send, &stat ) ;  }
1022   }
1023   yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
1024   yp_curs_recv = 0 ; ym_curs_recv = 0 ;
1025   xp_curs_recv = 0 ; xm_curs_recv = 0 ;
1026 #endif
1027 }
1028
1029 RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ,
1030                   int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p )
1031 {
1032   int me, np, np_x, np_y ;
1033   int yp, ym, xp, xm ;
1034 #ifndef STUBMPI
1035   MPI_Status stat ;
1036   MPI_Comm comm, *comm0, dummy_comm ;
1037
1038   comm0 = &dummy_comm ;
1039   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
1040   comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
1041   if ( np_x > 1 ) {
1042     MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
1043     if ( xp != MPI_PROC_NULL && *recvw_p > 0 ) {
1044       MPI_Irecv ( buffer_for_proc( xp, xp_curs_recv, RSL_RECVBUF ), xp_curs_recv, MPI_CHAR, xp, me, comm, &xp_recv ) ;
1045     }
1046     if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {
1047       MPI_Irecv ( buffer_for_proc( xm, xm_curs_recv, RSL_RECVBUF ), xm_curs_recv, MPI_CHAR, xm, me, comm, &xm_recv ) ;
1048     }
1049     if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {
1050       MPI_Isend ( buffer_for_proc( xp, 0,       RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
1051     }
1052     if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {
1053       MPI_Isend ( buffer_for_proc( xm, 0,       RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
1054     }
1055     if ( xp != MPI_PROC_NULL && *recvw_p > 0 ) {  MPI_Wait( &xp_recv, &stat ) ;  }
1056     if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {  MPI_Wait( &xm_recv, &stat ) ;  }
1057     if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {  MPI_Wait( &xp_send, &stat ) ;  }
1058     if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {  MPI_Wait( &xm_send, &stat ) ;  }
1059   }
1060   yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
1061   yp_curs_recv = 0 ; ym_curs_recv = 0 ;
1062   xp_curs_recv = 0 ; xm_curs_recv = 0 ;
1063 #endif
1064 }
1065
1066 #if !defined( MS_SUA)  && !defined(_WIN32)
1067 #include <sys/time.h>
1068 RSL_INTERNAL_MILLICLOCK ()
1069 {
1070     struct timeval tb ;
1071     struct timezone tzp ;
1072     int isec ;  /* seconds */
1073     int usec ;  /* microseconds */
1074     int msecs ;
1075     gettimeofday( &tb, &tzp ) ;
1076     isec = tb.tv_sec ;
1077     usec = tb.tv_usec ;
1078     msecs = 1000 * isec + usec / 1000 ;
1079     return(msecs) ;
1080 }
1081 RSL_INTERNAL_MICROCLOCK ()
1082 {
1083     struct timeval tb ;
1084     struct timezone tzp ;
1085     int isec ;  /* seconds */
1086     int usec ;  /* microseconds */
1087     int msecs ;
1088     gettimeofday( &tb, &tzp ) ;
1089     isec = tb.tv_sec ;
1090     usec = tb.tv_usec ;
1091     msecs = 1000000 * isec + usec ;
1092     return(msecs) ;
1093 }
1094 #endif