c_code.c
References to this file elsewhere.
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
23 RSL_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
178 BYTE_BCAST ( char * buf, int * size, int * Fcomm )
179 {
180 #ifndef STUBMPI
181 MPI_Comm *comm, dummy_comm ;
182
183 comm = &dummy_comm ;
184 *comm = MPI_Comm_f2c( *Fcomm ) ;
185 # ifdef crayx1
186 if (*size % sizeof(int) == 0) {
187 MPI_Bcast ( buf, *size/sizeof(int), MPI_INT, 0, *comm ) ;
188 } else {
189 MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
190 }
191 # else
192 MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
193 # endif
194 #endif
195 }
196
197 static int yp_curs, ym_curs, xp_curs, xm_curs ;
198
199 RSL_LITE_INIT_EXCH (
200 int * Fcomm0,
201 int * shw0,
202 int * n3dR0, int *n2dR0, int * typesizeR0 ,
203 int * n3dI0, int *n2dI0, int * typesizeI0 ,
204 int * n3dD0, int *n2dD0, int * typesizeD0 ,
205 int * n3dL0, int *n2dL0, int * typesizeL0 ,
206 int * me0, int * np0 , int * np_x0 , int * np_y0 ,
207 int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
208 {
209 int n3dR, n2dR, typesizeR ;
210 int n3dI, n2dI, typesizeI ;
211 int n3dD, n2dD, typesizeD ;
212 int n3dL, n2dL, typesizeL ;
213 int shw ;
214 int me, np, np_x, np_y ;
215 int ips , ipe , jps , jpe , kps , kpe ;
216 int yp, ym, xp, xm ;
217 int nbytes ;
218
219 #ifndef STUBMPI
220 MPI_Comm comm, *comm0, dummy_comm ;
221
222 comm0 = &dummy_comm ;
223 *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
224
225 shw = *shw0 ;
226 n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
227 n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
228 n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
229 n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
230 me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
231 ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
232
233 if ( np_y > 1 ) {
234 nbytes = typesizeR*(ipe-ips+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
235 typesizeI*(ipe-ips+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
236 typesizeD*(ipe-ips+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
237 typesizeL*(ipe-ips+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
238 MPI_Cart_shift ( *comm0, 0, 1, &ym, &yp ) ;
239 if ( yp != MPI_PROC_NULL ) {
240 buffer_for_proc ( yp , nbytes, RSL_RECVBUF ) ;
241 buffer_for_proc ( yp , nbytes, RSL_SENDBUF ) ;
242 }
243 if ( ym != MPI_PROC_NULL ) {
244 buffer_for_proc ( ym , nbytes, RSL_RECVBUF ) ;
245 buffer_for_proc ( ym , nbytes, RSL_SENDBUF ) ;
246 }
247 }
248 if ( np_x > 1 ) {
249 nbytes = typesizeR*(jpe-jps+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
250 typesizeI*(jpe-jps+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
251 typesizeD*(jpe-jps+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
252 typesizeL*(jpe-jps+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
253 MPI_Cart_shift ( *comm0, 1, 1, &xm, &xp ) ;
254 if ( xp != MPI_PROC_NULL ) {
255 buffer_for_proc ( xp , nbytes, RSL_RECVBUF ) ;
256 buffer_for_proc ( xp , nbytes, RSL_SENDBUF ) ;
257 }
258 if ( xm != MPI_PROC_NULL ) {
259 buffer_for_proc ( xm , nbytes, RSL_RECVBUF ) ;
260 buffer_for_proc ( xm , nbytes, RSL_SENDBUF ) ;
261 }
262 }
263 #endif
264 yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
265 }
266
267 RSL_LITE_PACK ( int * Fcomm0, char * buf , int * shw0 , int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * xstag0, /* not used */
268 int *me0, int * np0 , int * np_x0 , int * np_y0 ,
269 int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
270 int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
271 int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
272 {
273 int me, np, np_x, np_y ;
274 int shw , typesize ;
275 int ids , ide , jds , jde , kds , kde ;
276 int ims , ime , jms , jme , kms , kme ;
277 int ips , ipe , jps , jpe , kps , kpe ;
278 int xy ; /* y = 0 , x = 1 */
279 int pu ; /* pack = 0 , unpack = 1 */
280 register int i, j, k, t ;
281 #ifdef crayx1
282 register int i2,i3,i4,i_offset;
283 #endif
284 char *p ;
285 int da_buf ;
286 int yp, ym, xp, xm ;
287 int nbytes, ierr ;
288 register int *pi, *qi ;
289
290 #ifndef STUBMPI
291 MPI_Comm comm, *comm0, dummy_comm ;
292 int js, je, ks, ke, is, ie, wcount ;
293
294 comm0 = &dummy_comm ;
295 *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
296
297 me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
298 shw = *shw0 ; typesize = *typesize0 ;
299 ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
300 ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
301 ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
302 xy = *xy0 ;
303 pu = *pu0 ;
304
305 /* need to adapt for other memory orders */
306
307 #define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*((E3)-(S3)+1)*((E4)-(S4)+1))
308 #define IMAX(A) (((A)>ids)?(A):ids)
309 #define IMIN(A) (((A)<ide)?(A):ide)
310 #define JMAX(A) (((A)>jds)?(A):jds)
311 #define JMIN(A) (((A)<jde)?(A):jde)
312
313 da_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
314
315 if ( np_y > 1 && xy == 0 ) {
316 MPI_Cart_shift( *comm0 , 0, 1, &ym, &yp ) ;
317 if ( yp != MPI_PROC_NULL ) {
318 p = buffer_for_proc( yp , 0 , da_buf ) ;
319 if ( pu == 0 ) {
320 js = jpe-shw+1 ; je = jpe ;
321 ks = kps ; ke = kpe ;
322 is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
323 nbytes = buffer_size_for_proc( yp, da_buf ) ;
324 if ( yp_curs + RANGE( jpe-shw+1, jpe, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
325 #ifndef MS_SUA
326 fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack up, %d > %d\n",
327 yp_curs + RANGE( jpe-shw+1, jpe, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
328 #endif
329 MPI_Abort(MPI_COMM_WORLD, 99) ;
330 }
331 if ( typesize == 8 ) {
332 F_PACK_LINT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
333 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
334 yp_curs += wcount*typesize ;
335 }
336 else if ( typesize == 4 ) {
337 F_PACK_INT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
338 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
339 yp_curs += wcount*typesize ;
340 }
341 else {
342 #ifndef MS_SUA
343 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
344 #endif
345 }
346 } else {
347 js = jpe+1 ; je = jpe+shw ;
348 ks = kps ; ke = kpe ;
349 is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
350 if ( typesize == 8 ) {
351 F_UNPACK_LINT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
352 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
353 yp_curs += wcount*typesize ;
354 }
355 else if ( typesize == 4 ) {
356 F_UNPACK_INT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
357 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
358 yp_curs += wcount*typesize ;
359 }
360 else {
361 #ifndef MS_SUA
362 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
363 #endif
364 }
365 }
366 }
367 if ( ym != MPI_PROC_NULL ) {
368 p = buffer_for_proc( ym , 0 , da_buf ) ;
369 if ( pu == 0 ) {
370 js = jps ; je = jps+shw-1 ;
371 ks = kps ; ke = kpe ;
372 is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
373 nbytes = buffer_size_for_proc( ym, da_buf ) ;
374 if ( ym_curs + RANGE( jps, jps+shw-1, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
375 #ifndef MS_SUA
376 fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack dn, %d > %d\n",
377 ym_curs + RANGE( jps, jps+shw-1, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
378 #endif
379 MPI_Abort(MPI_COMM_WORLD, 99) ;
380 }
381 if ( typesize == 8 ) {
382 F_PACK_LINT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
383 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
384 ym_curs += wcount*typesize ;
385 }
386 else if ( typesize == 4 ) {
387 F_PACK_INT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
388 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
389 ym_curs += wcount*typesize ;
390 }
391 else {
392 #ifndef MS_SUA
393 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
394 #endif
395 }
396 } else {
397 js = jps-shw ; je = jps-1 ;
398 ks = kps ; ke = kpe ;
399 is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
400 if ( typesize == 8 ) {
401 F_UNPACK_LINT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
402 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
403 ym_curs += wcount*typesize ;
404 }
405 else if ( typesize == 4 ) {
406 F_UNPACK_INT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
407 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
408 ym_curs += wcount*typesize ;
409 }
410 else {
411 #ifndef MS_SUA
412 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
413 #endif
414 }
415 }
416 }
417 }
418
419 if ( np_x > 1 && xy == 1 ) {
420 MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
421 if ( xp != MPI_PROC_NULL ) {
422 p = buffer_for_proc( xp , 0 , da_buf ) ;
423 if ( pu == 0 ) {
424 js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
425 ks = kps ; ke = kpe ;
426 is = ipe-shw+1 ; ie = ipe ;
427 nbytes = buffer_size_for_proc( xp, da_buf ) ;
428 if ( xp_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ipe-shw+1, ipe, 1, typesize ) > nbytes ) {
429 #ifndef MS_SUA
430 fprintf(stderr,"memory overwrite in rsl_lite_pack, X pack right, %d > %d\n",
431 xp_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ipe-shw+1, ipe, 1, typesize ), nbytes ) ;
432 #endif
433 MPI_Abort(MPI_COMM_WORLD, 99) ;
434 }
435 if ( typesize == 8 ) {
436 F_PACK_LINT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
437 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
438 xp_curs += wcount*typesize ;
439 }
440 else if ( typesize == 4 ) {
441 F_PACK_INT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
442 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
443 xp_curs += wcount*typesize ;
444 }
445 else {
446 #ifndef MS_SUA
447 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
448 #endif
449 }
450 } else {
451 js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
452 ks = kps ; ke = kpe ;
453 is = ipe+1 ; ie = ipe+shw ;
454 if ( typesize == 8 ) {
455 F_UNPACK_LINT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
456 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
457 xp_curs += wcount*typesize ;
458 }
459 else if ( typesize == 4 ) {
460 F_UNPACK_INT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
461 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
462 xp_curs += wcount*typesize ;
463 }
464 else {
465 #ifndef MS_SUA
466 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
467 #endif
468 }
469 }
470 }
471 if ( xm != MPI_PROC_NULL ) {
472 p = buffer_for_proc( xm , 0 , da_buf ) ;
473 if ( pu == 0 ) {
474 js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
475 ks = kps ; ke = kpe ;
476 is = ips ; ie = ips+shw-1 ;
477 nbytes = buffer_size_for_proc( xm, da_buf ) ;
478 if ( xm_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ips, ips+shw-1, 1, typesize ) > nbytes ) {
479 #ifndef MS_SUA
480 fprintf(stderr,"memory overwrite in rsl_lite_pack, X left , %d > %d\n",
481 xm_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ips, ips+shw-1, 1, typesize ), nbytes ) ;
482 #endif
483 MPI_Abort(MPI_COMM_WORLD, 99) ;
484 }
485 if ( typesize == 8 ) {
486 F_PACK_LINT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
487 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
488 xm_curs += wcount*typesize ;
489 }
490 else if ( typesize == 4 ) {
491 F_PACK_INT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
492 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
493 xm_curs += wcount*typesize ;
494 }
495 else {
496 #ifndef MS_SUA
497 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
498 #endif
499 }
500 } else {
501 js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
502 ks = kps ; ke = kpe ;
503 is = ips-shw ; ie = ips-1 ;
504 if ( typesize == 8 ) {
505 F_UNPACK_LINT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
506 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
507 xm_curs += wcount*typesize ;
508 }
509 else if ( typesize == 4 ) {
510 F_UNPACK_INT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
511 &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
512 xm_curs += wcount*typesize ;
513 }
514 else {
515 #ifndef MS_SUA
516 fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
517 #endif
518 }
519 }
520 }
521 }
522 #endif
523
524 }
525
526 #ifndef STUBMPI
527 static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
528 static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
529 #endif
530
531 RSL_LITE_EXCH_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
532 {
533 int me, np, np_x, np_y ;
534 int yp, ym, xp, xm, ierr ;
535 #ifndef STUBMPI
536 MPI_Status stat ;
537 MPI_Comm comm, *comm0, dummy_comm ;
538
539 comm0 = &dummy_comm ;
540 *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
541 comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
542 if ( np_y > 1 ) {
543 MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
544 if ( yp != MPI_PROC_NULL ) {
545 ierr=MPI_Irecv ( buffer_for_proc( yp, yp_curs, RSL_RECVBUF ), yp_curs, MPI_CHAR, yp, me, comm, &yp_recv ) ;
546 }
547 if ( ym != MPI_PROC_NULL ) {
548 ierr=MPI_Irecv ( buffer_for_proc( ym, ym_curs, RSL_RECVBUF ), ym_curs, MPI_CHAR, ym, me, comm, &ym_recv ) ;
549 }
550 if ( yp != MPI_PROC_NULL ) {
551 ierr=MPI_Isend ( buffer_for_proc( yp, 0, RSL_SENDBUF ), yp_curs, MPI_CHAR, yp, yp, comm, &yp_send ) ;
552 }
553 if ( ym != MPI_PROC_NULL ) {
554 ierr=MPI_Isend ( buffer_for_proc( ym, 0, RSL_SENDBUF ), ym_curs, MPI_CHAR, ym, ym, comm, &ym_send ) ;
555 }
556 if ( yp != MPI_PROC_NULL ) MPI_Wait( &yp_recv, &stat ) ;
557 if ( ym != MPI_PROC_NULL ) MPI_Wait( &ym_recv, &stat ) ;
558 if ( yp != MPI_PROC_NULL ) MPI_Wait( &yp_send, &stat ) ;
559 if ( ym != MPI_PROC_NULL ) MPI_Wait( &ym_send, &stat ) ;
560 }
561 yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
562 #endif
563 }
564
565 RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
566 {
567 int me, np, np_x, np_y ;
568 int yp, ym, xp, xm ;
569 #ifndef STUBMPI
570 MPI_Status stat ;
571 MPI_Comm comm, *comm0, dummy_comm ;
572
573 comm0 = &dummy_comm ;
574 *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
575 comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
576 if ( np_x > 1 ) {
577 MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
578 if ( xp != MPI_PROC_NULL ) {
579 MPI_Irecv ( buffer_for_proc( xp, xp_curs, RSL_RECVBUF ), xp_curs, MPI_CHAR, xp, me, comm, &xp_recv ) ;
580 }
581 if ( xm != MPI_PROC_NULL ) {
582 MPI_Irecv ( buffer_for_proc( xm, xm_curs, RSL_RECVBUF ), xm_curs, MPI_CHAR, xm, me, comm, &xm_recv ) ;
583 }
584 if ( xp != MPI_PROC_NULL ) {
585 MPI_Isend ( buffer_for_proc( xp, 0, RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
586 }
587 if ( xm != MPI_PROC_NULL ) {
588 MPI_Isend ( buffer_for_proc( xm, 0, RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
589 }
590 if ( xp != MPI_PROC_NULL ) MPI_Wait( &xp_recv, &stat ) ;
591 if ( xm != MPI_PROC_NULL ) MPI_Wait( &xm_recv, &stat ) ;
592 if ( xp != MPI_PROC_NULL ) MPI_Wait( &xp_send, &stat ) ;
593 if ( xm != MPI_PROC_NULL ) MPI_Wait( &xm_send, &stat ) ;
594 }
595 yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
596 #endif
597 }
598
599 #ifndef MS_SUA
600 #include <sys/time.h>
601 RSL_INTERNAL_MILLICLOCK ()
602 {
603 struct timeval tb ;
604 struct timezone tzp ;
605 int isec ; /* seconds */
606 int usec ; /* microseconds */
607 int msecs ;
608 gettimeofday( &tb, &tzp ) ;
609 isec = tb.tv_sec ;
610 usec = tb.tv_usec ;
611 msecs = 1000 * isec + usec / 1000 ;
612 return(msecs) ;
613 }
614 RSL_INTERNAL_MICROCLOCK ()
615 {
616 struct timeval tb ;
617 struct timezone tzp ;
618 int isec ; /* seconds */
619 int usec ; /* microseconds */
620 int msecs ;
621 gettimeofday( &tb, &tzp ) ;
622 isec = tb.tv_sec ;
623 usec = tb.tv_usec ;
624 msecs = 1000000 * isec + usec ;
625 return(msecs) ;
626 }
627 #endif