source: trunk/WRF.COMMON/WRFV3/external/RSL_LITE/c_code.c @ 3568

Last change on this file since 3568 was 2759, checked in by aslmd, 3 years ago

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