wrfv2_fire/external/RSL_LITE/period.c

   1 #ifndef MS_SUA
   2 # include <stdio.h>
   3 #endif
   4 #include <fcntl.h>
   5
   6 #define STANDARD_ERROR 2
   7
   8 #define STANDARD_OUTPUT 1
   9
  10 #ifndef STUBMPI
  11 # include "mpi.h"
  12 #endif
  13 #include "rsl_lite.h"
  14
  15 static int yp_curs, ym_curs, xp_curs, xm_curs ;
  16
  17 RSL_LITE_INIT_PERIOD (
  18                 int * Fcomm0,
  19                 int * shw0,
  20                 int * n3dR0, int *n2dR0, int * typesizeR0 ,
  21                 int * n3dI0, int *n2dI0, int * typesizeI0 ,
  22                 int * n3dD0, int *n2dD0, int * typesizeD0 ,
  23                 int * n3dL0, int *n2dL0, int * typesizeL0 ,
  24                 int * me0, int * np0 , int * np_x0 , int * np_y0 ,
  25                 int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
  26 {
  27 #ifndef STUBMPI
  28   int n3dR, n2dR, typesizeR ;
  29   int n3dI, n2dI, typesizeI ;
  30   int n3dD, n2dD, typesizeD ;
  31   int n3dL, n2dL, typesizeL ;
  32   int shw ;
  33   int me, np, np_x, np_y ;
  34   int ips , ipe , jps , jpe , kps , kpe ;
  35   int yp, ym, xp, xm ;
  36   int nbytes ;
  37   int coords[2] ;
  38   MPI_Comm comm, *comm0, dummy_comm ;
  39
  40   comm0 = &dummy_comm ;
  41   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
  42
  43   shw = *shw0 ;
  44   n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
  45   n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
  46   n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
  47   n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
  48   me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
  49   ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
  50
  51 /*
  52  This assumes that the topoology associated with the communicator is periodic
  53  the period routines should be called with "local_communicator_periodic", which
  54  is set up in module_dm.F for RSL_LITE.  Registry generated code automatically
  55  does this (gen_comms.c for RSL_LITE).
  56 */
  57   if ( np_y > 1 ) {
  58     nbytes = typesizeR*(ipe-ips+1+2*shw)*(shw+1)*(n3dR*(kpe-kps+1)+n2dR) +
  59              typesizeI*(ipe-ips+1+2*shw)*(shw+1)*(n3dI*(kpe-kps+1)+n2dI) +
  60              typesizeD*(ipe-ips+1+2*shw)*(shw+1)*(n3dD*(kpe-kps+1)+n2dD) +
  61              typesizeL*(ipe-ips+1+2*shw)*(shw+1)*(n3dL*(kpe-kps+1)+n2dL) ;
  62     MPI_Comm_rank( *comm0, &me ) ;
  63     MPI_Cart_coords( *comm0, me, 2, coords ) ;
  64     MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
  65     if ( yp != MPI_PROC_NULL && coords[0] == np_y - 1 ) {  /* process on top of mesh */
  66        buffer_for_proc ( yp , nbytes, RSL_RECVBUF ) ;
  67        buffer_for_proc ( yp , nbytes, RSL_SENDBUF ) ;
  68     }
  69     if ( ym != MPI_PROC_NULL && coords[0] == 0 ) {         /* process on bottom of mesh */
  70        buffer_for_proc ( ym , nbytes, RSL_RECVBUF ) ;
  71        buffer_for_proc ( ym , nbytes, RSL_SENDBUF ) ;
  72     }
  73   }
  74   if ( np_x > 1 ) {
  75     nbytes = typesizeR*(jpe-jps+1+2*shw)*(shw+1)*(n3dR*(kpe-kps+1)+n2dR) +
  76              typesizeI*(jpe-jps+1+2*shw)*(shw+1)*(n3dI*(kpe-kps+1)+n2dI) +
  77              typesizeD*(jpe-jps+1+2*shw)*(shw+1)*(n3dD*(kpe-kps+1)+n2dD) +
  78              typesizeL*(jpe-jps+1+2*shw)*(shw+1)*(n3dL*(kpe-kps+1)+n2dL) ;
  79     MPI_Comm_rank( *comm0, &me ) ;
  80     MPI_Cart_coords( *comm0, me, 2, coords ) ;
  81     MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
  82     if ( xm != MPI_PROC_NULL && coords[1] == np_x - 1 ) { /* process on right hand side of mesh */
  83        buffer_for_proc ( xp , nbytes, RSL_RECVBUF ) ;
  84        buffer_for_proc ( xp , nbytes, RSL_SENDBUF ) ;
  85     }
  86     if ( xp != MPI_PROC_NULL && coords[1] == 0 ) {        /* process on left hand side of mesh */
  87        buffer_for_proc ( xm,  nbytes, RSL_RECVBUF ) ;
  88        buffer_for_proc ( xm , nbytes, RSL_SENDBUF ) ;
  89     }
  90   }
  91   yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
  92 #endif
  93 }
  94
  95
  96 RSL_LITE_PACK_PERIOD ( int* Fcomm0, char * buf , int * shw0 , int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * stag0 ,
  97            int *me0, int * np0 , int * np_x0 , int * np_y0 ,
  98            int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
  99            int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
 100            int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
 101 {
 102 #ifndef STUBMPI
 103   int me, np, np_x, np_y ;
 104   int shw , typesize ;
 105   int ids , ide , jds , jde , kds , kde ;
 106   int ims , ime , jms , jme , kms , kme ;
 107   int ips , ipe , jps , jpe , kps , kpe ;
 108   int stag ;  /* 0 not stag, 1 stag */
 109   int xy ;   /* y = 0 , x = 1 */
 110   int pu ;   /* pack = 0 , unpack = 1 */
 111   register int i, j, k, t ;
 112 #ifdef crayx1
 113   register int i2,i3,i4,i_offset;
 114 #endif
 115   char *p ;
 116   int the_buf ;
 117   int yp, ym, xp, xm ;
 118   int nbytes, ierr ;
 119   register int *pi, *qi ;
 120   int coords[2] ;
 121   int js, je, ks, ke, is, ie, wcount ;
 122   MPI_Comm comm, *comm0, dummy_comm ;
 123
 124   comm0 = &dummy_comm ;
 125   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
 126
 127   me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
 128   stag = *stag0 ;
 129   shw = *shw0 ; typesize = *typesize0 ;
 130   ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
 131   ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
 132   ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
 133   xy = *xy0 ;
 134   pu = *pu0 ;
 135
 136 #define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*((E3)-(S3)+1)*((E4)-(S4)+1))
 137 #if 0
 138 #define IMAX(A) (((A)>ids)?(A):ids)
 139 #define IMIN(A) (((A)<ide)?(A):ide)
 140 #define JMAX(A) (((A)>jds)?(A):jds)
 141 #define JMIN(A) (((A)<jde)?(A):jde)
 142 #else
 143 /* allow the extent in other dimension to go into boundary region (e.g. < ids or > ide) since
 144    this will handle corner points for doubly periodic updates (he wrote hopefully) */
 145 #define IMAX(A) (A)
 146 #define IMIN(A) (A)
 147 #define JMAX(A) (A)
 148 #define JMIN(A) (A)
 149 #endif
 150
 151   the_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
 152
 153   if ( np_x > 1 && xy == 1 ) {   /* exchange period in x dim */
 154     MPI_Comm_rank( *comm0, &me ) ;
 155     MPI_Cart_coords( *comm0, me, 2, coords ) ;
 156     MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
 157     if ( coords[1] == np_x - 1 ) {                /* process on right hand edge of domain */
 158       p = buffer_for_proc( xp , 0 , the_buf ) ;
 159       if ( pu == 0 ) {
 160         js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 161         ks = kps           ; ke = kpe ;
 162         is = ipe-shw       ; ie = ipe-1         ;
 163         nbytes = buffer_size_for_proc( xp , the_buf ) ;
 164         if ( xp_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ipe-shw, ipe-1, 1, typesize ) > nbytes ) {
 165 #ifndef MS_SUA
 166           fprintf(stderr,"memory overwrite in rsl_lite_pack_period_x, right hand X to %d, %d > %d\n",xp,
 167               xp_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ipe-shw, ipe-1, 1, typesize ), nbytes ) ;
 168 #endif
 169           MPI_Abort(MPI_COMM_WORLD, 98) ;
 170         }
 171         if ( typesize == 8 ) {
 172           F_PACK_LINT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 173                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 174           xp_curs += wcount*typesize ;
 175         } else
 176         if ( typesize == 4 ) {
 177           F_PACK_INT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 178                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 179           xp_curs += wcount*typesize ;
 180         }
 181         else {
 182 #ifndef MS_SUA
 183           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 184 #endif
 185         }
 186       } else {
 187         js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 188         ks = kps           ; ke = kpe ;
 189         is = ipe           ; ie = ipe+shw-1+stag ;
 190         if ( typesize == 8 ) {
 191           F_UNPACK_LINT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 192                                           &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 193           xp_curs += wcount*typesize ;
 194         } else
 195         if ( typesize == 4 ) {
 196           F_UNPACK_INT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 197                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 198           xp_curs += wcount*typesize ;
 199         }
 200         else {
 201 #ifndef MS_SUA
 202           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 203 #endif
 204         }
 205       }
 206     }
 207     if ( coords[1] == 0 ) {         /* process on left hand edge of domain */
 208       p = buffer_for_proc( xm , 0 , the_buf ) ;
 209       if ( pu == 0 ) {
 210         js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 211         ks = kps           ; ke = kpe ;
 212         is = ips           ; ie = ips+shw-1+stag ;
 213         nbytes = buffer_size_for_proc( xm , the_buf ) ;
 214         if ( xm_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ips, ips+shw-1+stag, 1, typesize ) > nbytes ) {
 215 #ifndef MS_SUA
 216           fprintf(stderr,"memory overwrite in rsl_lite_pack_period_x,  left hand X to %d , %d > %d\n",xm,
 217               xm_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ips, ips+shw-1+stag, 1, typesize ), nbytes ) ;
 218 #endif
 219           MPI_Abort(MPI_COMM_WORLD, 98) ;
 220         }
 221         if ( typesize == 8 ) {
 222           F_PACK_LINT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 223                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 224           xm_curs += wcount*typesize ;
 225         } else
 226         if ( typesize == 4 ) {
 227           F_PACK_INT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 228                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 229           xm_curs += wcount*typesize ;
 230         }
 231         else {
 232 #ifndef MS_SUA
 233           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 234 #endif
 235         }
 236       } else {
 237         js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
 238         ks = kps           ; ke = kpe ;
 239         is = ips-shw       ; ie = ips-1           ;
 240         if ( typesize == 8 ) {
 241           F_UNPACK_LINT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 242                                           &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 243           xm_curs += wcount*typesize ;
 244         } else
 245         if ( typesize == 4 ) {
 246           F_UNPACK_INT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 247                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 248           xm_curs += wcount*typesize ;
 249         }
 250         else {
 251 #ifndef MS_SUA
 252           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 253 #endif
 254         }
 255       }
 256     }
 257   }
 258   if ( np_y > 1 && xy == 0 ) {    /* exchange period in Y dim */
 259     MPI_Comm_rank( *comm0, &me ) ;
 260     MPI_Cart_coords( *comm0, me, 2, coords ) ;
 261     MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
 262     if ( coords[0] == np_y - 1 ) {                /* process on top edge of domain */
 263       p = buffer_for_proc( yp , 0 , the_buf ) ;
 264       if ( pu == 0 ) {
 265         is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 266         ks = kps           ; ke = kpe ;
 267         js = jpe-shw       ; je = jpe-1         ;
 268         nbytes = buffer_size_for_proc( yp , the_buf ) ;
 269         if ( yp_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jpe-shw, jpe-1, 1, typesize ) > nbytes ) {
 270 #ifndef MS_SUA
 271           fprintf(stderr,"memory overwrite in rsl_lite_pack_period_y, right hand Y to %d, %d > %d\n",yp,
 272               yp_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jpe-shw, jpe-1, 1, typesize ), nbytes ) ;
 273 #endif
 274           MPI_Abort(MPI_COMM_WORLD, 98) ;
 275         }
 276         if ( typesize == 8 ) {
 277           F_PACK_LINT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 278                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 279           yp_curs += wcount*typesize ;
 280         } else
 281         if ( typesize == 4 ) {
 282           F_PACK_INT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 283                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 284           yp_curs += wcount*typesize ;
 285         }
 286         else {
 287 #ifndef MS_SUA
 288           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 289 #endif
 290         }
 291       } else {
 292         is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 293         ks = kps           ; ke = kpe ;
 294         js = jpe           ; je = jpe+shw-1+stag ;
 295         if ( typesize == 8 ) {
 296           F_UNPACK_LINT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 297                                           &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 298           yp_curs += wcount*typesize ;
 299         } else
 300         if ( typesize == 4 ) {
 301           F_UNPACK_INT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 302                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 303           yp_curs += wcount*typesize ;
 304         }
 305         else {
 306 #ifndef MS_SUA
 307           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 308 #endif
 309         }
 310       }
 311     }
 312     if ( coords[0] == 0 ) {         /* process on bottom edge of domain */
 313       p = buffer_for_proc( ym , 0 , the_buf ) ;
 314       if ( pu == 0 ) {
 315         is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 316         ks = kps           ; ke = kpe ;
 317         js = jps           ; je = jps+shw-1+stag ;
 318         nbytes = buffer_size_for_proc( ym , the_buf ) ;
 319         if ( ym_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jps, jps+shw-1+stag, 1, typesize ) > nbytes ) {
 320 #ifndef MS_SUA
 321           fprintf(stderr,"memory overwrite in rsl_lite_pack_period_y,  left hand Y to %d , %d > %d\n",xm,
 322               ym_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jps, jps+shw-1+stag, 1, typesize ), nbytes ) ;
 323 #endif
 324           MPI_Abort(MPI_COMM_WORLD, 98) ;
 325         }
 326         if ( typesize == 8 ) {
 327           F_PACK_LINT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 328                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 329           ym_curs += wcount*typesize ;
 330         } else
 331         if ( typesize == 4 ) {
 332           F_PACK_INT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
 333                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 334           ym_curs += wcount*typesize ;
 335         }
 336         else {
 337 #ifndef MS_SUA
 338           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 339 #endif
 340         }
 341       } else {
 342         is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
 343         ks = kps           ; ke = kpe ;
 344         js = jps-shw       ; je = jps-1           ;
 345         if ( typesize == 8 ) {
 346           F_UNPACK_LINT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 347                                           &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 348           ym_curs += wcount*typesize ;
 349         } else
 350         if ( typesize == 4 ) {
 351           F_UNPACK_INT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
 352                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
 353           ym_curs += wcount*typesize ;
 354         }
 355         else {
 356 #ifndef MS_SUA
 357           fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
 358 #endif
 359         }
 360       }
 361     }
 362   }
 363 #endif
 364 }
 365
 366 #ifndef STUBMPI
 367 static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
 368 static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
 369 #endif
 370
 371 RSL_LITE_EXCH_PERIOD_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
 372 {
 373 #ifndef STUBMPI
 374   int me, np, np_x, np_y ;
 375   int yp, ym, xp, xm, nbytes ;
 376   MPI_Status stat ;
 377   MPI_Comm comm, *comm0, dummy_comm ;
 378   int coords[2] ;
 379
 380   comm0 = &dummy_comm ;
 381   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
 382 #if 1
 383   comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
 384
 385   if ( np_x > 1 ) {
 386     MPI_Comm_rank( *comm0, &me ) ;
 387     MPI_Cart_coords( *comm0, me, 2, coords ) ;
 388     MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
 389     if ( coords[1] == np_x - 1 ) {   /* proc on right hand side of domain */
 390       nbytes = buffer_size_for_proc( xp, RSL_RECVBUF ) ;
 391       MPI_Irecv ( buffer_for_proc( xp , xp_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, xp, me, comm, &xp_recv ) ;
 392     }
 393     if ( coords[1] == 0 ) {          /* proc on left hand side of domain */
 394       nbytes = buffer_size_for_proc( xm, RSL_RECVBUF ) ;
 395       MPI_Irecv ( buffer_for_proc( xm, xm_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, xm, me, comm, &xm_recv ) ;
 396     }
 397     if ( coords[1] == np_x - 1 ) {   /* proc on right hand side of domain */
 398       MPI_Isend ( buffer_for_proc( xp , 0,       RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
 399     }
 400     if ( coords[1] == 0 ) {          /* proc on left hand side of domain */
 401       MPI_Isend ( buffer_for_proc( xm, 0,       RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
 402     }
 403     if ( coords[1] == np_x - 1 ) MPI_Wait( &xp_recv, &stat ) ;
 404     if ( coords[1] == 0        ) MPI_Wait( &xm_recv, &stat ) ;
 405     if ( coords[1] == np_x - 1 ) MPI_Wait( &xp_send, &stat ) ;
 406     if ( coords[1] == 0        ) MPI_Wait( &xm_send, &stat ) ;
 407   }
 408 #else
 409 # ifndef MS_SUA
 410 fprintf(stderr,"RSL_LITE_EXCH_PERIOD_X disabled\n") ;
 411 # endif
 412 #endif
 413   yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
 414 #endif
 415 }
 416
 417 RSL_LITE_EXCH_PERIOD_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
 418 {
 419 #ifndef STUBMPI
 420   int me, np, np_x, np_y ;
 421   int yp, ym, xp, xm, nbytes ;
 422   MPI_Status stat ;
 423   MPI_Comm comm, *comm0, dummy_comm ;
 424   int coords[2] ;
 425
 426   comm0 = &dummy_comm ;
 427   *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
 428 #if 1
 429   comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
 430
 431   if ( np_y > 1 ) {
 432     MPI_Comm_rank( *comm0, &me ) ;
 433     MPI_Cart_coords( *comm0, me, 2, coords ) ;
 434     MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
 435     if ( coords[0] == np_y - 1 ) {   /* proc on top of domain */
 436       nbytes = buffer_size_for_proc( yp, RSL_RECVBUF ) ;
 437       MPI_Irecv ( buffer_for_proc( yp , yp_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, yp, me, comm, &yp_recv ) ;
 438     }
 439     if ( coords[0] == 0 ) {          /* proc on bottom of domain */
 440       nbytes = buffer_size_for_proc( ym, RSL_RECVBUF ) ;
 441       MPI_Irecv ( buffer_for_proc( ym, ym_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, ym, me, comm, &ym_recv ) ;
 442     }
 443     if ( coords[0] == np_y - 1 ) {   /* proc on top of domain */
 444       MPI_Isend ( buffer_for_proc( yp , 0,       RSL_SENDBUF ), yp_curs, MPI_CHAR, yp, yp, comm, &yp_send ) ;
 445     }
 446     if ( coords[0] == 0 ) {          /* proc on bottom of domain */
 447       MPI_Isend ( buffer_for_proc( ym, 0,       RSL_SENDBUF ), ym_curs, MPI_CHAR, ym, ym, comm, &ym_send ) ;
 448     }
 449     if ( coords[0] == np_y - 1 ) MPI_Wait( &yp_recv, &stat ) ;
 450     if ( coords[0] == 0        ) MPI_Wait( &ym_recv, &stat ) ;
 451     if ( coords[0] == np_y - 1 ) MPI_Wait( &yp_send, &stat ) ;
 452     if ( coords[0] == 0        ) MPI_Wait( &ym_send, &stat ) ;
 453   }
 454 #else
 455 # ifndef MS_SUA
 456 fprintf(stderr,"RSL_LITE_EXCH_PERIOD_Y disabled\n") ;
 457 # endif
 458 #endif
 459   yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
 460 #endif
 461 }
 462