source: lmdz_wrf/trunk/WRFV3/external/RSL_LITE/c_code.c @ 729

Last change on this file since 729 was 1, checked in by lfita, 11 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

  • Property svn:executable set to *
File size: 26.8 KB
Line 
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
12#ifdef _WIN32
13#include <Winsock2.h>
14#endif
15
16#define STANDARD_ERROR 2
17
18#define STANDARD_OUTPUT 1
19
20#ifndef STUBMPI
21#  include "mpi.h"
22#endif
23#include "rsl_lite.h"
24
25#define F_PACK
26
27RSL_LITE_ERROR_DUP1 ( int *me )
28{
29    int newfd,rc ;
30    char filename[256] ;
31    char dirname[256] ;
32    char hostname[256] ;
33
34/* redirect standard out and standard error based on compile options*/
35                                                                                                                                             
36#ifndef NCEP_DEBUG_MULTIDIR
37    gethostname( hostname, 256 ) ;
38
39/* redirect standard out*/
40    sprintf(filename,"rsl.out.%04d",*me) ;
41    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
42    {
43        perror("error_dup: cannot open rsl.out.nnnn") ;
44        fprintf(stderr,"...sending output to standard output and continuing.\n") ;
45        return ;
46    }
47    if( dup2( newfd, STANDARD_OUTPUT ) < 0 )
48    {
49        perror("error_dup: dup2 fails to change output descriptor") ;
50        fprintf(stderr,"...sending output to standard output and continuing.\n") ;
51        close(newfd) ;
52        return ;
53    }
54
55/* redirect standard error */
56# if defined( _WIN32 )
57    if ( *me != 0 ) {   /* stderr from task 0 should come to screen on windows because it is buffered if redirected */
58#endif
59    sprintf(filename,"rsl.error.%04d",*me) ;
60    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
61    {
62        perror("error_dup: cannot open rsl.error.log") ;
63        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
64        return ;
65    }
66    if( dup2( newfd, STANDARD_ERROR ) < 0 )
67    {
68        perror("error_dup: dup2 fails to change error descriptor") ;
69        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
70        close(newfd) ;
71        return ;
72    }
73    fprintf( stdout, "taskid: %d hostname: %s\n",*me,hostname) ;
74    fprintf( stderr, "taskid: %d hostname: %s\n",*me,hostname) ;
75# if defined( _WIN32 )
76    }
77# endif
78#else
79# ifndef NCEP_DEBUG_GLOBALSTDOUT
80
81/*create TASKOUTPUT directory to contain separate task owned output directories*/
82                                                                                                                                             
83   /* let task 0 create the subdirectory path for the task directories */
84                                                                                                                                             
85    if (*me == 0)
86    {
87        sprintf(dirname, "%s","TASKOUTPUT");
88        rc = mkdir(dirname, 0777);
89        if ( rc != 0 && errno==EEXIST) rc=0;
90    }
91                                                                                                                                             
92    /* If TASKOUTPUT directory is not created then return */
93                                                                                                                                             
94    MPI_Bcast(&rc, 1, MPI_INTEGER, 0, MPI_COMM_WORLD);
95                                                                                                                                             
96    if (rc != 0 ) {
97       if (*me == 0 ) {
98          perror("mkdir error");
99          fprintf(stderr, "mkdir failed for directory %s on task %d. Sending error/output to stderr/stdout for all tasks and continuing.\n", dirname, *me);
100          return;
101       }
102       else {
103          return;
104       }
105    }
106       
107    /* TASKOUTPUT directory exists, continue with task specific directory */
108                                                                                                                                             
109    sprintf(dirname, "TASKOUTPUT/%04d", *me);
110    rc=mkdir(dirname, 0777);
111    if (  rc !=0 && errno!=EEXIST ) {
112        perror("mkdir error");
113        fprintf(stderr, "mkdir failed for directory %s on task %d. Sending error/output to stderr/stdout and continuing.\n", dirname, *me);
114        return;
115    }
116                                                                                                                                             
117   /* Each tasks creates/opens its own output and error files */
118                                                                                                                                             
119   sprintf(filename, "%s/%04d/rsl.out.%04d","TASKOUTPUT",*me,*me) ;
120       
121   if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
122   {
123        perror("error_dup: cannot open ./TASKOUTPUT/nnnn/rsl.out.nnnn") ;
124        fprintf(stderr,"...sending output to standard output and continuing.\n")
125 ;
126        return ;
127   }
128   if( dup2( newfd, STANDARD_OUTPUT ) < 0 )
129   {
130        perror("error_dup: dup2 fails to change output descriptor") ;
131        fprintf(stderr,"...sending output to standard output and continuing.\n");
132        close(newfd) ;
133        return ;
134   }
135       
136   sprintf(filename, "%s/%04d/rsl.error.%04d","TASKOUTPUT",*me,*me) ;
137   if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
138   {
139       perror("error_dup: cannot open ./TASKOUTPUT/nnnn/rsl.error.nnnn") ;
140       fprintf(stderr,"...sending error to standard error and continuing.\n") ;
141       return ;
142   }
143   if( dup2( newfd, STANDARD_ERROR ) < 0 )
144   {
145       perror("error_dup: dup2 fails to change error descriptor") ;
146       fprintf(stderr,"...sending error to standard error and continuing.\n") ;
147       close(newfd) ;
148       return ;
149   }
150# else
151/* Each task writes to global standard error and standard out */
152     
153   return;
154     
155# endif
156#endif
157}
158
159#ifdef _WIN32
160/* Windows doesn't have a gethostid function so add a stub.
161   TODO: Create a version that will work on Windows. */
162int
163gethostid ()
164{
165        return 0;
166}
167#endif
168
169RSL_LITE_GET_HOSTNAME ( char * hn, int * size, int *n, int *hostid ) 
170{
171   char temp[512] ;
172   char *p, *q ; 
173   int i, cs ;
174   if ( gethostname(temp,512) ) return(1) ;
175   cs = gethostid() ;
176   for ( p = temp , q = hn , i = 0 ; *p && i < *size && i < 512 ; i++ , p++ , q++ ) { *q = *p ; }
177   *n = i ;
178   *hostid = cs ;
179   return(0) ;
180}
181
182BYTE_BCAST ( char * buf, int * size, int * Fcomm )
183{
184#ifndef STUBMPI
185    MPI_Comm *comm, dummy_comm ;
186
187    comm = &dummy_comm ;
188    *comm = MPI_Comm_f2c( *Fcomm ) ;
189# ifdef crayx1
190    if (*size % sizeof(int) == 0) {
191       MPI_Bcast ( buf, *size/sizeof(int), MPI_INT, 0, *comm ) ;
192    } else {
193       MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
194    }
195# else
196    MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
197# endif
198#endif
199}
200
201static int yp_curs, ym_curs, xp_curs, xm_curs ;
202static int yp_curs_recv, ym_curs_recv, xp_curs_recv, xm_curs_recv ;
203
204RSL_LITE_INIT_EXCH ( 
205                int * Fcomm0,
206                int * shw0,  int * xy0 ,
207                int *sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 ,
208                int *recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 ,
209                int * n3dR0, int *n2dR0, int * typesizeR0 , 
210                int * n3dI0, int *n2dI0, int * typesizeI0 , 
211                int * n3dD0, int *n2dD0, int * typesizeD0 , 
212                int * n3dL0, int *n2dL0, int * typesizeL0 , 
213                int * me0, int * np0 , int * np_x0 , int * np_y0 ,
214                int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
215{
216  int n3dR, n2dR, typesizeR ;
217  int n3dI, n2dI, typesizeI ;
218  int n3dD, n2dD, typesizeD ;
219  int n3dL, n2dL, typesizeL ;
220  int shw ;
221  int sendbegm , sendwm, sendbegp , sendwp ;
222  int recvbegm , recvwm, recvbegp , recvwp ;
223  int me, np, np_x, np_y ;
224  int ips , ipe , jps , jpe , kps , kpe ;
225  int xy ;
226  int yp, ym, xp, xm ;
227  int nbytes ;
228  int nbytes_x_recv = 0, nbytes_y_recv = 0 ;
229
230#ifndef STUBMPI
231  MPI_Comm comm, *comm0, dummy_comm ;
232
233  comm0 = &dummy_comm ;
234  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
235
236  shw = *shw0 ;          /* logical half-width of stencil */
237  xy = *xy0 ;              /* 0 = y , 1 = x */
238  sendbegm = *sendbegm0 ;  /* send index of sten copy (edge = 1), lower/left */
239  sendwm   = *sendwm0   ;  /* send width of sten copy counting towards edge, lower/left */
240  sendbegp = *sendbegp0 ;  /* send index of sten copy (edge = 1), upper/right */
241  sendwp   = *sendwp0   ;  /* send width of sten copy counting towards edge, upper/right */
242  recvbegm = *recvbegm0 ;  /* recv index of sten copy (edge = 1), lower/left */
243  recvwm   = *recvwm0   ;  /* recv width of sten copy counting towards edge, lower/left */
244  recvbegp = *recvbegp0 ;  /* recv index of sten copy (edge = 1), upper/right */
245  recvwp   = *recvwp0   ;  /* recv width of sten copy counting towards edge, upper/right */
246  n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
247  n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
248  n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
249  n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
250  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
251  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
252
253  yp_curs_recv = 0 ; ym_curs_recv = 0 ; 
254  xp_curs_recv = 0 ; xm_curs_recv = 0 ;
255
256  if ( xy == 0 && np_y > 1 ) {
257    nbytes = typesizeR*(ipe-ips+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
258             typesizeI*(ipe-ips+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
259             typesizeD*(ipe-ips+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
260             typesizeL*(ipe-ips+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
261    nbytes_y_recv = 
262             typesizeR*(ipe-ips+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
263             typesizeI*(ipe-ips+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
264             typesizeD*(ipe-ips+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
265             typesizeL*(ipe-ips+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
266    MPI_Cart_shift ( *comm0, 0, 1, &ym, &yp ) ;
267    if ( yp != MPI_PROC_NULL ) {
268       buffer_for_proc ( yp , nbytes_y_recv, RSL_RECVBUF ) ;
269       buffer_for_proc ( yp , nbytes, RSL_SENDBUF ) ;
270    }
271    if ( ym != MPI_PROC_NULL ) {
272       buffer_for_proc ( ym , nbytes_y_recv, RSL_RECVBUF ) ;
273       buffer_for_proc ( ym , nbytes, RSL_SENDBUF ) ;
274    }
275  }
276  if ( xy == 1 && np_x > 1 ) {
277    nbytes = typesizeR*(jpe-jps+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
278             typesizeI*(jpe-jps+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
279             typesizeD*(jpe-jps+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
280             typesizeL*(jpe-jps+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
281    nbytes_x_recv = 
282             typesizeR*(jpe-jps+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
283             typesizeI*(jpe-jps+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
284             typesizeD*(jpe-jps+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
285             typesizeL*(jpe-jps+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
286    MPI_Cart_shift ( *comm0, 1, 1, &xm, &xp ) ;
287    if ( xp != MPI_PROC_NULL ) {
288       buffer_for_proc ( xp , nbytes_x_recv, RSL_RECVBUF ) ;
289       buffer_for_proc ( xp , nbytes, RSL_SENDBUF ) ;
290    }
291    if ( xm != MPI_PROC_NULL ) {
292       buffer_for_proc ( xm , nbytes_x_recv, RSL_RECVBUF ) ;
293       buffer_for_proc ( xm , nbytes, RSL_SENDBUF ) ;
294    }
295  }
296#endif
297  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
298  yp_curs_recv = nbytes_y_recv ; ym_curs_recv = nbytes_y_recv ; 
299  xp_curs_recv = nbytes_x_recv ; xm_curs_recv = nbytes_x_recv ;
300}
301
302RSL_LITE_PACK ( int * Fcomm0, char * buf , int * shw0 , 
303           int * sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 ,
304           int * recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 ,
305           int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * xstag0, /* not used */
306           int *me0, int * np0 , int * np_x0 , int * np_y0 , 
307           int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
308           int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
309           int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
310{
311  int me, np, np_x, np_y ;
312  int sendbegm , sendwm, sendbegp , sendwp ;
313  int recvbegm , recvwm, recvbegp , recvwp ;
314  int shw , typesize ;
315  int ids , ide , jds , jde , kds , kde ;
316  int ims , ime , jms , jme , kms , kme ;
317  int ips , ipe , jps , jpe , kps , kpe ;
318  int xy ;   /* y = 0 , x = 1 */
319  int pu ;   /* pack = 0 , unpack = 1 */
320  register int i, j, k, t ;
321#ifdef crayx1
322  register int i2,i3,i4,i_offset;
323#endif
324  char *p ;
325  int da_buf ;
326  int yp, ym, xp, xm ;
327  int nbytes, ierr ;
328  register int *pi, *qi ;
329
330#ifndef STUBMPI
331  MPI_Comm comm, *comm0, dummy_comm ;
332  int js, je, ks, ke, is, ie, wcount ;
333
334  comm0 = &dummy_comm ;
335  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
336
337  shw = *shw0 ;          /* logical half-width of stencil */
338  sendbegm = *sendbegm0 ;  /* send index of sten copy (edge = 1), lower/left */
339  sendwm   = *sendwm0   ;  /* send width of sten copy counting towards edge, lower/left */
340  sendbegp = *sendbegp0 ;  /* send index of sten copy (edge = 1), upper/right */
341  sendwp   = *sendwp0   ;  /* send width of sten copy counting towards edge, upper/right */
342  recvbegm = *recvbegm0 ;  /* recv index of sten copy (edge = 1), lower/left */
343  recvwm   = *recvwm0   ;  /* recv width of sten copy counting towards edge, lower/left */
344  recvbegp = *recvbegp0 ;  /* recv index of sten copy (edge = 1), upper/right */
345  recvwp   = *recvwp0   ;  /* recv width of sten copy counting towards edge, upper/right */
346  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
347  typesize = *typesize0 ;
348  ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
349  ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
350  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
351  xy = *xy0 ;
352  pu = *pu0 ;
353
354/* need to adapt for other memory orders */
355
356#define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*((E3)-(S3)+1)*((E4)-(S4)+1))
357#define IMAX(A) (((A)>ids)?(A):ids)
358#define IMIN(A) (((A)<ide)?(A):ide)
359#define JMAX(A) (((A)>jds)?(A):jds)
360#define JMIN(A) (((A)<jde)?(A):jde)
361
362  da_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
363
364  if ( ips <= ipe && jps <= jpe ) {
365
366  if ( np_y > 1 && xy == 0 ) {
367    MPI_Cart_shift( *comm0 , 0, 1, &ym, &yp ) ;
368    if ( yp != MPI_PROC_NULL && jpe <= jde  && jde != jpe ) {
369      p = buffer_for_proc( yp , 0 , da_buf ) ;
370      if ( pu == 0 ) {
371        if ( sendwp > 0 ) {
372          je = jpe - sendbegp + 1 ; js = je - sendwp + 1 ;
373          ks = kps           ; ke = kpe ;
374          is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
375          nbytes = buffer_size_for_proc( yp, da_buf ) ;
376          if ( yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
377#ifndef MS_SUA
378            fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack up, %d > %d\n",
379                yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
380#endif
381            MPI_Abort(MPI_COMM_WORLD, 99) ;
382          }
383          if ( typesize == 8 ) {
384            F_PACK_LINT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie, 
385                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
386            yp_curs += wcount*typesize ;
387          }
388          else if ( typesize == 4 ) {
389            F_PACK_INT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
390                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
391            yp_curs += wcount*typesize ;
392          }
393          else {
394#ifndef MS_SUA
395            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
396#endif
397          }
398        }
399      } else {
400        if ( recvwp > 0 ) {
401          js = jpe+recvbegp         ; je = js + recvwp - 1 ;
402          ks = kps           ; ke = kpe ;
403          is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
404          if ( typesize == 8 ) {
405            F_UNPACK_LINT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
406                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
407            yp_curs += wcount*typesize ;
408          }
409          else if ( typesize == 4 ) {
410            F_UNPACK_INT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
411                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
412            yp_curs += wcount*typesize ;
413          }
414          else {
415#ifndef MS_SUA
416            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
417#endif
418          }
419        }
420      }
421    }
422    if ( ym != MPI_PROC_NULL && jps >= jds  && jps != jds ) {
423      p = buffer_for_proc( ym , 0 , da_buf ) ;
424      if ( pu == 0 ) {
425        if ( sendwm > 0 ) {
426          js = jps+sendbegm-1 ; je = js + sendwm -1 ;
427          ks = kps           ; ke = kpe ;
428          is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
429          nbytes = buffer_size_for_proc( ym, da_buf ) ;
430          if ( ym_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
431#ifndef  MS_SUA
432            fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack dn, %d > %d\n",
433                ym_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
434#endif
435            MPI_Abort(MPI_COMM_WORLD, 99) ;
436          }
437          if ( typesize == 8 ) {
438            F_PACK_LINT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
439                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
440            ym_curs += wcount*typesize ;
441          }
442          else if ( typesize == 4 ) {
443            F_PACK_INT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
444                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
445            ym_curs += wcount*typesize ;
446          }
447          else {
448#ifndef MS_SUA
449            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
450#endif
451          }
452        }
453      } else {
454        if ( recvwm > 0 ) {
455          je = jps-recvbegm ; js = je - recvwm + 1 ;
456          ks = kps           ; ke = kpe ;
457          is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
458          if ( typesize == 8 ) {
459            F_UNPACK_LINT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
460                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
461            ym_curs += wcount*typesize ;
462          }
463          else if ( typesize == 4 ) {
464            F_UNPACK_INT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
465                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
466            ym_curs += wcount*typesize ;
467          }
468          else {
469#ifndef MS_SUA
470            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
471#endif
472          }
473        }
474      }
475    }
476  }
477
478  if ( np_x > 1 && xy == 1 ) {
479    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
480    if ( xp != MPI_PROC_NULL  && ipe <= ide && ide != ipe ) {
481      p = buffer_for_proc( xp , 0 , da_buf ) ;
482      if ( pu == 0 ) {
483        if ( sendwp > 0 ) {
484          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
485          ks = kps           ; ke = kpe ;
486          ie = ipe - sendbegp + 1 ; is = ie - sendwp + 1 ;
487          nbytes = buffer_size_for_proc( xp, da_buf ) ;
488          if ( xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ) > nbytes ) {
489#ifndef MS_SUA
490            fprintf(stderr,"memory overwrite in rsl_lite_pack, X pack right, %d > %d\n",
491                xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ), nbytes ) ;
492#endif
493            MPI_Abort(MPI_COMM_WORLD, 99) ;
494          }
495          if ( typesize == 8 ) {
496            F_PACK_LINT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
497                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
498            xp_curs += wcount*typesize ;
499          }
500          else if ( typesize == 4 ) {
501            F_PACK_INT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
502                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
503            xp_curs += wcount*typesize ;
504          }
505          else {
506#ifndef MS_SUA
507            fprintf(stderr,"A internal error: %s %d\n",__FILE__,__LINE__) ;
508#endif
509          }
510        }
511      } else {
512        if ( recvwp > 0 ) {
513          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
514          ks = kps           ; ke = kpe ;
515          is = ipe+recvbegp  ; ie = is + recvwp - 1 ;
516          if ( typesize == 8 ) {
517            F_UNPACK_LINT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
518                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
519            xp_curs += wcount*typesize ;
520          }
521          else if ( typesize == 4 ) {
522            F_UNPACK_INT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
523                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
524            xp_curs += wcount*typesize ;
525          }
526          else {
527#ifndef MS_SUA
528            fprintf(stderr,"B internal error: %s %d\n",__FILE__,__LINE__) ;
529            fprintf(stderr,"  stenbeg %d stenw  %d \n",is,ie) ;
530            fprintf(stderr,"  is %d ie %d \n",is,ie) ;
531#endif
532          }
533        }
534      }
535    }
536    if ( xm != MPI_PROC_NULL  && ips >= ids && ids != ips ) {
537      p = buffer_for_proc( xm , 0 , da_buf ) ;
538      if ( pu == 0 ) {
539        if ( sendwm > 0 ) {
540          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
541          ks = kps           ; ke = kpe ;
542          is = ips+sendbegm-1 ; ie = is + sendwm-1 ;
543          nbytes = buffer_size_for_proc( xm, da_buf ) ;
544          if ( xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ) > nbytes ) {
545#ifndef MS_SUA
546            fprintf(stderr,"memory overwrite in rsl_lite_pack, X left , %d > %d\n",
547                xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ), nbytes ) ;
548#endif
549            MPI_Abort(MPI_COMM_WORLD, 99) ;
550          }
551          if ( typesize == 8 ) {
552            F_PACK_LINT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
553                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
554            xm_curs += wcount*typesize ;
555          }
556          else if ( typesize == 4 ) {
557            F_PACK_INT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
558                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
559            xm_curs += wcount*typesize ;
560          }
561          else {
562#ifndef MS_SUA
563            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
564#endif
565          }
566        }
567      } else {
568        if ( recvwm > 0 ) {
569          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
570          ks = kps           ; ke = kpe ;
571          ie = ips-recvbegm ; is = ie - recvwm + 1 ;
572          if ( typesize == 8 ) {
573            F_UNPACK_LINT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
574                                                  &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
575            xm_curs += wcount*typesize ;
576          } 
577          else if ( typesize == 4 ) {
578            F_UNPACK_INT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
579                                                 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
580            xm_curs += wcount*typesize ;
581          }
582          else {
583#ifndef MS_SUA
584            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
585#endif
586          }
587        }
588      }
589    }
590  }
591  }
592#endif
593
594}
595
596#ifndef STUBMPI
597static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
598static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
599#endif
600
601RSL_LITE_EXCH_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ,
602                  int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p )
603{
604  int me, np, np_x, np_y ;
605  int yp, ym, xp, xm, ierr ;
606#ifndef STUBMPI
607  MPI_Status stat ;
608  MPI_Comm comm, *comm0, dummy_comm ;
609
610  comm0 = &dummy_comm ;
611  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
612  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
613  if ( np_y > 1 ) {
614    MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
615    if ( yp != MPI_PROC_NULL && *recvw_p > 0 ) {
616      ierr=MPI_Irecv ( buffer_for_proc( yp, yp_curs_recv, RSL_RECVBUF ), yp_curs_recv, MPI_CHAR, yp, me, comm, &yp_recv ) ;
617    }
618    if ( ym != MPI_PROC_NULL && *recvw_m > 0 ) {
619      ierr=MPI_Irecv ( buffer_for_proc( ym, ym_curs_recv, RSL_RECVBUF ), ym_curs_recv, MPI_CHAR, ym, me, comm, &ym_recv ) ;
620    }
621    if ( yp != MPI_PROC_NULL && *sendw_p > 0 ) {
622      ierr=MPI_Isend ( buffer_for_proc( yp, 0,       RSL_SENDBUF ), yp_curs, MPI_CHAR, yp, yp, comm, &yp_send ) ;
623    }
624    if ( ym != MPI_PROC_NULL && *sendw_m > 0 ) {
625      ierr=MPI_Isend ( buffer_for_proc( ym, 0,       RSL_SENDBUF ), ym_curs, MPI_CHAR, ym, ym, comm, &ym_send ) ;
626    }
627    if ( yp != MPI_PROC_NULL && *recvw_p > 0 ) {  MPI_Wait( &yp_recv, &stat ) ;  }
628    if ( ym != MPI_PROC_NULL && *recvw_m > 0 ) {  MPI_Wait( &ym_recv, &stat ) ;  }
629    if ( yp != MPI_PROC_NULL && *sendw_p > 0 ) {  MPI_Wait( &yp_send, &stat ) ;  }
630    if ( ym != MPI_PROC_NULL && *sendw_m > 0 ) {  MPI_Wait( &ym_send, &stat ) ;  }
631  }
632  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
633  yp_curs_recv = 0 ; ym_curs_recv = 0 ; 
634  xp_curs_recv = 0 ; xm_curs_recv = 0 ;
635#endif
636}
637
638RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ,
639                  int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p )
640{
641  int me, np, np_x, np_y ;
642  int yp, ym, xp, xm ;
643#ifndef STUBMPI
644  MPI_Status stat ;
645  MPI_Comm comm, *comm0, dummy_comm ;
646
647  comm0 = &dummy_comm ;
648  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
649  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
650  if ( np_x > 1 ) {
651    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
652    if ( xp != MPI_PROC_NULL && *recvw_p > 0 ) {
653      MPI_Irecv ( buffer_for_proc( xp, xp_curs_recv, RSL_RECVBUF ), xp_curs_recv, MPI_CHAR, xp, me, comm, &xp_recv ) ;
654    }
655    if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {
656      MPI_Irecv ( buffer_for_proc( xm, xm_curs_recv, RSL_RECVBUF ), xm_curs_recv, MPI_CHAR, xm, me, comm, &xm_recv ) ;
657    }
658    if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {
659      MPI_Isend ( buffer_for_proc( xp, 0,       RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
660    }
661    if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {
662      MPI_Isend ( buffer_for_proc( xm, 0,       RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
663    }
664    if ( xp != MPI_PROC_NULL && *recvw_p > 0 ) {  MPI_Wait( &xp_recv, &stat ) ;  }
665    if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {  MPI_Wait( &xm_recv, &stat ) ;  }
666    if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {  MPI_Wait( &xp_send, &stat ) ;  }
667    if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {  MPI_Wait( &xm_send, &stat ) ;  }
668  }
669  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
670  yp_curs_recv = 0 ; ym_curs_recv = 0 ; 
671  xp_curs_recv = 0 ; xm_curs_recv = 0 ;
672#endif
673}
674
675#if !defined( MS_SUA)  && !defined(_WIN32)
676#include <sys/time.h>
677RSL_INTERNAL_MILLICLOCK ()
678{
679    struct timeval tb ;
680    struct timezone tzp ;
681    int isec ;  /* seconds */
682    int usec ;  /* microseconds */
683    int msecs ;
684    gettimeofday( &tb, &tzp ) ;
685    isec = tb.tv_sec ;
686    usec = tb.tv_usec ;
687    msecs = 1000 * isec + usec / 1000 ;
688    return(msecs) ;
689}
690RSL_INTERNAL_MICROCLOCK ()
691{
692    struct timeval tb ;
693    struct timezone tzp ;
694    int isec ;  /* seconds */
695    int usec ;  /* microseconds */
696    int msecs ;
697    gettimeofday( &tb, &tzp ) ;
698    isec = tb.tv_sec ;
699    usec = tb.tv_usec ;
700    msecs = 1000000 * isec + usec ;
701    return(msecs) ;
702}
703#endif
Note: See TracBrowser for help on using the repository browser.