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