1 #if HAVE_CONFIG_H
2 # include "config.h"
3 #endif
4
5 /*$Id: global.util.c,v 1.48.6.6 2007-05-18 08:19:23 manoj Exp $*/
6 /*
7 * module: global.util.c
8 * author: Jarek Nieplocha
9 * last modification: Tue Dec 20 09:41:55 PDT 1994
10 *
11 * DISCLAIMER
12 *
13 * This material was prepared as an account of work sponsored by an
14 * agency of the United States Government. Neither the United States
15 * Government nor the United States Department of Energy, nor Battelle,
16 * nor any of their employees, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
17 * ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
18 * COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT,
19 * SOFTWARE, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
20 * INFRINGE PRIVATELY OWNED RIGHTS.
21 *
22 *
23 * ACKNOWLEDGMENT
24 *
25 * This software and its documentation were produced with United States
26 * Government support under Contract Number DE-AC06-76RLO-1830 awarded by
27 * the United States Department of Energy. The United States Government
28 * retains a paid-up non-exclusive, irrevocable worldwide license to
29 * reproduce, prepare derivative works, perform publicly and display
30 * publicly by or for the US Government, including the right to
31 * distribute to other US Government contractors.
32 */
33 #if HAVE_STDIO_H
34 # include <stdio.h>
35 #endif
36 #if HAVE_STRING_H
37 # include <string.h>
38 #endif
39 #if HAVE_SYS_TYPES_H
40 # include <sys/types.h>
41 #endif
42 #if HAVE_UNISTD_H
43 # include <unistd.h>
44 #endif
45
46 #include "farg.h"
47 #include "globalp.h"
48 #include <armci.h>
49 #include "ga-papi.h"
50 #include "ga-wapi.h"
51
52 #define ARMCI 1
53
54 #if defined(SUN)
55 void fflush();
56 #endif
57
58 /*\ PRINT g_a[ilo:ihi, jlo:jhi]
59 \*/
60 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
61 # pragma weak wnga_print_patch_file2d = pnga_print_patch_file2d
62 #endif
pnga_print_patch_file2d(file,g_a,ilo,ihi,jlo,jhi,pretty)63 void pnga_print_patch_file2d(file, g_a, ilo, ihi, jlo, jhi, pretty)
64 FILE *file;
65 Integer g_a, ilo, ihi, jlo, jhi, pretty;
66 /*
67 Pretty = 0 ... spew output out with no formatting
68 Pretty = 1 ... format output so that it is readable
69 */
70 {
71 #define BUFSIZE 6
72 #define FLEN 80
73 Integer i, j,jj, dim1, dim2, type, jmax, ld=1, bufsize ;
74 Integer a_grp;
75 int ibuf[BUFSIZE];
76 DoublePrecision dbuf[BUFSIZE];
77 float fbuf[BUFSIZE];
78 long lbuf[BUFSIZE];
79 long long llbuf[BUFSIZE];
80 char *name;
81 Integer ndim, dims[2];
82 Integer lo[2], hi[2];
83
84 a_grp = pnga_get_pgroup(g_a);
85 pnga_pgroup_sync(a_grp);
86 pnga_check_handle(g_a, "ga_print");
87 if(pnga_pgroup_nodeid(a_grp) == 0){
88
89 pnga_inquire(g_a, &type, &ndim, dims);
90 dim1 = dims[0];
91 dim2 = dims[1];
92 /* name[FLEN-1]='\0';*/
93 pnga_inquire_name(g_a, &name);
94 if (ilo <= 0 || ihi > dim1 || jlo <= 0 || jhi > dim2){
95 fprintf(stderr,"%ld %ld %ld %ld dims: [%ld,%ld]\n",
96 (long)ilo,(long)ihi, (long)jlo,(long)jhi,
97 (long)dim1, (long)dim2);
98 pnga_error(" ga_print: indices out of range ", g_a);
99 }
100
101 fprintf(file,"\n global array: %s[%ld:%ld,%ld:%ld], handle: %d \n",
102 name, (long)ilo, (long)ihi, (long)jlo, (long)jhi, (int)g_a);
103
104 bufsize = (type==C_DCPL)? BUFSIZE/2 : BUFSIZE;
105 bufsize = (type==C_SCPL)? BUFSIZE/2 : BUFSIZE;
106
107
108 if (!pretty) {
109 for (i=ilo; i <ihi+1; i++){
110 for (j=jlo; j <jhi+1; j+=bufsize){
111 jmax = GA_MIN(j+bufsize-1,jhi);
112 lo[0] = i;
113 lo[1] = j;
114 hi[0] = i;
115 hi[1] = jmax;
116 switch(type){
117 case C_INT:
118 pnga_get(g_a, lo, hi, ibuf, &ld);
119 for(jj=0; jj<(jmax-j+1); jj++)
120 fprintf(file," %8d",ibuf[jj]);
121 break;
122 case C_DBL:
123 pnga_get(g_a, lo, hi, dbuf, &ld);
124 for(jj=0; jj<(jmax-j+1); jj++)
125 fprintf(file," %11.5f",dbuf[jj]);
126 break;
127 case C_DCPL:
128 pnga_get(g_a, lo, hi, dbuf, &ld);
129 for(jj=0; jj<(jmax-j+1); jj+=2)
130 fprintf(file," %11.5f,%11.5f",dbuf[jj], dbuf[jj+1]);
131 break;
132 case C_SCPL:
133 pnga_get(g_a, lo, hi, dbuf, &ld);
134 for(jj=0; jj<(jmax-j+1); jj+=2)
135 fprintf(file," %11.5f,%11.5f",dbuf[jj], dbuf[jj+1]);
136 break;
137 case C_FLOAT:
138 pnga_get(g_a, lo, hi, fbuf, &ld);
139 for(jj=0; jj<(jmax-j+1); jj++)
140 fprintf(file," %11.5f",fbuf[jj]);
141 break;
142 case C_LONG:
143 pnga_get(g_a, lo, hi, lbuf, &ld);
144 for(jj=0; jj<(jmax-j+1); jj++)
145 fprintf(file," %8ld",lbuf[jj]);
146 break;
147 case C_LONGLONG:
148 pnga_get(g_a, lo, hi, llbuf, &ld);
149 for(jj=0; jj<(jmax-j+1); jj++)
150 fprintf(file," %8lld",llbuf[jj]);
151 break;
152 default: pnga_error("ga_print: wrong type",0);
153 }
154 }
155 fprintf(file,"\n");
156 }
157 fflush(file);
158
159 } else {
160
161 for (j=jlo; j<jhi+1; j+=bufsize){
162 jmax = GA_MIN(j+bufsize-1,jhi);
163
164 fprintf(file, "\n"); fprintf(file, "\n");
165
166 /* Print out column headers */
167
168 fprintf(file, " ");
169 switch(type){
170 case C_INT:
171 for (jj=j; jj<=jmax; jj++) fprintf(file, "%6ld ", (long)jj);
172 fprintf(file,"\n ");
173 for (jj=j; jj<=jmax; jj++) fprintf(file," -------");
174 break;
175 case C_LONG:
176 for (jj=j; jj<=jmax; jj++) fprintf(file, "%6ld ", (long)jj);
177 fprintf(file,"\n ");
178 for (jj=j; jj<=jmax; jj++) fprintf(file," -------");
179 break;
180 case C_LONGLONG:
181 for (jj=j; jj<=jmax; jj++) fprintf(file, "%6ld ", (long)jj);
182 fprintf(file,"\n ");
183 for (jj=j; jj<=jmax; jj++) fprintf(file," -------");
184 break;
185 case C_DCPL:
186 for (jj=j; jj<=jmax; jj++) fprintf(file,"%20ld ", (long)jj);
187 fprintf(file,"\n ");
188 for (jj=j; jj<=2*jmax; jj++) fprintf(file," -----------");
189 break;
190 case C_SCPL:
191 for (jj=j; jj<=jmax; jj++) fprintf(file,"%20ld ", (long)jj);
192 fprintf(file,"\n ");
193 for (jj=j; jj<=2*jmax; jj++) fprintf(file," -----------");
194 break;
195 case C_DBL:
196 for (jj=j; jj<=jmax; jj++) fprintf(file,"%8ld ", (long)jj);
197 fprintf(file,"\n ");
198 for (jj=j; jj<=jmax; jj++) fprintf(file," -----------");
199 case C_FLOAT:
200 for (jj=j; jj<=jmax; jj++) fprintf(file,"%8ld ", (long)jj);
201 fprintf(file,"\n ");
202 for (jj=j; jj<=jmax; jj++) fprintf(file," -----------");
203 }
204 fprintf(file,"\n");
205
206 for(i=ilo; i <ihi+1; i++){
207 fprintf(file,"%4ld ",(long)i);
208
209 lo[0] = i;
210 lo[1] = i;
211 hi[0] = j;
212 hi[1] = jmax;
213 switch(type){
214 case C_INT:
215 pnga_get(g_a, lo, hi, ibuf, &ld);
216 for(jj=0; jj<(jmax-j+1); jj++)
217 fprintf(file," %8d",ibuf[jj]);
218 break;
219 case C_LONG:
220 pnga_get(g_a, lo, hi, lbuf, &ld);
221 for(jj=0; jj<(jmax-j+1); jj++)
222 fprintf(file," %8ld",lbuf[jj]);
223 break;
224 case C_LONGLONG:
225 pnga_get(g_a, lo, hi, llbuf, &ld);
226 for(jj=0; jj<(jmax-j+1); jj++)
227 fprintf(file," %8lld",llbuf[jj]);
228 break;
229 case C_DBL:
230 pnga_get(g_a, lo, hi, dbuf, &ld);
231 for(jj=0; jj<(jmax-j+1); jj++)
232 fprintf(file," %11.5f",dbuf[jj]);
233 break;
234 case C_FLOAT:
235 pnga_get(g_a, lo, hi, dbuf, &ld);
236 for(jj=0; jj<(jmax-j+1); jj++)
237 fprintf(file," %11.5f",fbuf[jj]);
238 break;
239 case C_DCPL:
240 pnga_get(g_a, lo, hi, dbuf, &ld);
241 for(jj=0; jj<(jmax-j+1); jj+=2)
242 fprintf(file," %11.5f,%11.5f",dbuf[jj], dbuf[jj+1]);
243 break;
244 case C_SCPL:
245 pnga_get(g_a, lo, hi, dbuf, &ld);
246 for(jj=0; jj<(jmax-j+1); jj+=2)
247 fprintf(file," %11.5f,%11.5f",dbuf[jj], dbuf[jj+1]);
248 break;
249 default: pnga_error("ga_print: wrong type",0);
250 }
251 fprintf(file,"\n");
252 }
253 fflush(file);
254 }
255 }
256 }
257
258 pnga_pgroup_sync(a_grp);
259 }
260
261 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
262 # pragma weak wnga_print_patch2d = pnga_print_patch2d
263 #endif
pnga_print_patch2d(g_a,ilo,ihi,jlo,jhi,pretty)264 void pnga_print_patch2d(g_a, ilo, ihi, jlo, jhi, pretty)
265 Integer g_a, ilo, ihi, jlo, jhi, pretty;
266 {
267 pnga_print_patch_file2d(stdout, g_a, ilo, ihi, jlo, jhi, pretty);
268 }
269
270 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
271 # pragma weak wnga_print_stats = pnga_print_stats
272 #endif
pnga_print_stats()273 void pnga_print_stats()
274 {
275 int i;
276 GAstat_arr = (long*)&GAstat;
277 #ifdef __crayx1
278 #ifdef NO_GA_STATS
279 printf("\tNOTE:GA stats have been disabled on x1 for some GA calls, to enable them comment the line LIB_DEFINES += -DNO_GA_STATS in global/src/GNUmakefile under the GA directory");
280 #endif
281 #endif
282 printf("\n GA Statistics for process %4d\n",(int)pnga_nodeid());
283 printf(" ------------------------------\n\n");
284 printf(" create destroy get put acc scatter gather read&inc\n");
285
286 printf("calls: ");
287 for(i=0;i<8;i++)
288 if(GAstat_arr[i] < 9999) printf("%4ld ",GAstat_arr[i]);
289 else printf("%.2e ",(double)GAstat_arr[i]);
290 printf("\n");
291 if(GAstat.numget==0)GAstat.numget=1;
292 if(GAstat.numput==0)GAstat.numput=1;
293 if(GAstat.numacc==0)GAstat.numacc=1;
294 if(GAstat.numsca==0)GAstat.numsca=1;
295 if(GAstat.numgat==0)GAstat.numgat=1;
296 printf("number of processes/call %.2e %.2e %.2e %.2e %.2e\n",
297 ((double)GAstat.numget_procs)/(double)GAstat.numget,
298 ((double)GAstat.numput_procs)/(double)GAstat.numput,
299 ((double)GAstat.numacc_procs)/(double)GAstat.numacc,
300 ((double)GAstat.numsca_procs)/(double)GAstat.numsca,
301 ((double)GAstat.numgat_procs)/(double)GAstat.numgat);
302
303
304 printf("bytes total: %.2e %.2e %.2e %.2e %.2e %.2e\n",
305 GAbytes.gettot, GAbytes.puttot, GAbytes.acctot,
306 GAbytes.scatot, GAbytes.gattot, GAbytes.rditot);
307
308 printf("bytes remote: %.2e %.2e %.2e %.2e %.2e %.2e\n",
309 GAbytes.gettot - GAbytes.getloc,
310 GAbytes.puttot - GAbytes.putloc,
311 GAbytes.acctot - GAbytes.accloc,
312 GAbytes.scatot - GAbytes.scaloc,
313 GAbytes.gattot - GAbytes.gatloc,
314 GAbytes.rditot - GAbytes.rdiloc);
315
316 printf("Max memory consumed for GA by this process: %ld bytes\n",GAstat.maxmem);
317 if(GAstat.numser)
318 printf("Number of requests serviced: %ld\n",GAstat.numser);
319 fflush(stdout);
320 }
321
322
323
324
325 /**
326 * Error termination
327 */
328 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
329 # pragma weak wnga_error = pnga_error
330 #endif
331
pnga_error(char * string,Integer icode)332 void pnga_error(char *string, Integer icode)
333 {
334 #ifndef ARMCI
335 extern void Error();
336 #endif
337
338 #ifdef CRAY_T3D
339 # define FOUT stdout
340 #else
341 # define FOUT stderr
342 #endif
343 #define ERR_LEN 400
344 int level;
345 char error_buffer[ERR_LEN];
346
347 /* JAD 02/23/2012 for applications, an exit/error code of 0 indicates
348 * success, it is therefore wrong to call pnga_error with a zero value */
349 if (icode == 0) {
350 icode = -1;
351 }
352
353 /* print GA names stack */
354 sprintf(error_buffer,"%d:", (int)pnga_nodeid());
355 strcat(error_buffer,string);
356 strcat(error_buffer,":");
357
358 #ifdef ARMCI
359 ARMCI_Error(error_buffer,(int)icode);
360 #else
361 ga_clean_resources();
362 if (pnga_nnodes() > 1) Error(error_buffer, icode);
363 else{
364 fprintf(FOUT,"%s %ld\n",error_buffer,icode);
365 perror("system message:");
366 fflush(FOUT);
367 exit(1);
368 }
369 #endif
370 }
371
ga_debug_suspend()372 void ga_debug_suspend()
373 {
374 #if HAVE_PAUSE
375 fprintf(stdout,"ga_debug: process %ld ready for debugging\n",
376 (long)getpid());
377 fflush(stdout);
378 pause();
379 #endif
380 }
381
382
383
384
385
386
387
388
389 #ifdef ARMCI
390
391 /*********************************************************************
392 * N-dimensional operations *
393 *********************************************************************/
394
395
396 /*\ print range of n-dimensional array with two strings before and after
397 \*/
gai_print_range(char * pre,int ndim,Integer lo[],Integer hi[],char * post)398 static void gai_print_range(char *pre,int ndim,
399 Integer lo[], Integer hi[], char* post)
400 {
401 int i;
402
403 printf("%s[",pre);
404 for(i=0;i<ndim;i++){
405 printf("%ld:%ld",(long)lo[i],(long)hi[i]);
406 if(i==ndim-1)printf("] %s",post);
407 else printf(",");
408 }
409 }
410
411
swap(Integer * a,Integer * b)412 static void swap(Integer *a, Integer *b)
413 {
414 Integer tmp;
415 tmp = *a;
416 *a = *b;
417 *b = tmp;
418 }
419
420
421 /*\ prints array distribution in C or Fortran style
422 \*/
423 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
424 # pragma weak wnga_print_distribution = pnga_print_distribution
425 #endif
pnga_print_distribution(int fstyle,Integer g_a)426 void pnga_print_distribution(int fstyle, Integer g_a)
427 {
428 Integer ndim, i, proc, type, nproc=pnga_nnodes();
429 Integer dims[MAXDIM], lo[MAXDIM], hi[MAXDIM];
430 char msg[100];
431 char ctype[128];
432 char *name;
433 int local_sync_begin,local_sync_end;
434
435 local_sync_begin = _ga_sync_begin; local_sync_end = _ga_sync_end;
436 _ga_sync_begin = 1; _ga_sync_end=1; /*remove any previous masking*/
437 if(local_sync_begin)pnga_sync();
438
439 if(pnga_nodeid() ==0){
440 pnga_inquire(g_a, &type, &ndim, dims);
441 pnga_inquire_name(g_a, &name);
442 printf("Array Handle=%d Name:'%s' ",(int)g_a, name);
443 printf("Data Type:");
444 switch(type){
445 case C_DBL: printf("double"); break;
446 case C_INT: printf("integer"); break;
447 case C_DCPL: printf("double complex"); break;
448 case C_SCPL: printf("float (single) complex"); break;
449 case C_FLOAT: printf("float"); break;
450 case C_LONG: printf("long"); break;
451 case C_LONGLONG: printf("long long"); break;
452 default: pnga_error("ga_print_distribution: type not supported",type);
453 }
454 printf("\nArray Dimensions:");
455 if(fstyle){
456 for(i=0; i<ndim-1; i++)printf("%ldx",(long)dims[i]);
457 printf("%ld\n",(long)dims[ndim-1]);
458 }else{
459 for(i=ndim-1; i>0; i--)printf("%ldx",(long)dims[i]);
460 printf("%ld\n",(long)dims[0]);
461 }
462
463 /* print array range for every processor */
464
465 pnga_get_distribution_type(g_a, ctype);
466 if (!strcmp(ctype,"regular")) {
467 for(proc = 0; proc < nproc; proc++){
468 pnga_distribution(g_a,proc,lo,hi);
469 sprintf(msg,"Process=%d\t owns array section: ",(int)proc);
470
471 /* for C style need to swap and decremenent by 1 both arrays */
472 if(!fstyle){
473 for(i=0; i<ndim/2; i++){
474 swap(lo+i,lo+ndim-i-1);
475 swap(hi+i,hi+ndim-i-1);
476 }
477 for(i=0; i<ndim; i++)lo[i]--;
478 for(i=0; i<ndim; i++)hi[i]--;
479 }
480 gai_print_range(msg,(int)ndim,lo,hi,"\n");
481 }
482 } else if (!strcmp(ctype,"block_cyclic")) {
483 Integer nblocks[MAXDIM];
484 Integer total, j;
485 pnga_nblock(g_a,nblocks);
486 printf("\nDistribution is block-cyclic\n");
487 total = 1;
488 for (i=0; i<ndim; i++) {
489 total *= nblocks[i];
490 }
491 printf("\nTotal of %d blocks on %d processors\n",total,nproc);
492 for (i=0; i<nproc; i++) {
493 printf("Distribution on process %d\n",i);
494 for (j=i; j<total; j += nproc) {
495 pnga_distribution(g_a,j,lo,hi);
496 sprintf(msg," Block=%d\t corresponds to array section: ",(int)j);
497 /* for C style need to swap and decremenent by 1 both arrays */
498 if(!fstyle){
499 for(i=0; i<ndim/2; i++){
500 swap(lo+i,lo+ndim-i-1);
501 swap(hi+i,hi+ndim-i-1);
502 }
503 for(i=0; i<ndim; i++)lo[i]--;
504 for(i=0; i<ndim; i++)hi[i]--;
505 }
506 gai_print_range(msg,(int)ndim,lo,hi,"\n");
507 }
508 }
509 } else if (!strcmp(ctype,"scalapack") ||
510 !strcmp(ctype,"tiled_irreg") || !strcmp(ctype,"tiled")) {
511 Integer nblocks[MAXDIM], proc_grid[MAXDIM], proc_idx[MAXDIM];
512 Integer index[MAXDIM];
513 Integer ok, j, idx;
514 pnga_nblock(g_a,nblocks);
515 char *ptr;
516 if (!strcmp(ctype,"scalapack")) {
517 printf("\nDistribution is ScaLAPACK\n");
518 } else if (!strcmp(ctype,"tiled_irreg")) {
519 printf("\nDistribution is Tiled Irregular\n");
520 } else if (!strcmp(ctype,"tiled")) {
521 printf("\nDistribution is Tiled\n");
522 }
523
524 printf("\n");
525 printf("Number of blocks in each dimension: [");
526 for (i=0; i<ndim-1; i++) printf("%d,",nblocks[i]);
527 printf("%d]\n\n",nblocks[ndim-1]);
528
529 pnga_get_proc_grid(g_a,proc_grid);
530 printf("Processor grid dimensions: [");
531 for (i=0; i<ndim-1; i++) printf("%d,",proc_grid[i]);
532 printf("%d]\n\n",nblocks[ndim-1]);
533
534 for (i=0; i<nproc; i++) {
535 printf("Distribution on process %d\n",i);
536 pnga_get_proc_index(g_a,i,proc_idx);
537 pnga_get_proc_index(g_a,i,index);
538 ok = 1;
539 while (ok) {
540 /* find block index */
541 idx = 0;
542 for (j=ndim-1; j>=0; j--) {
543 idx = idx*nblocks[j]+index[j];
544 }
545 sprintf(msg," idx: %d Block=[",idx);
546 pnga_distribution(g_a,idx,lo,hi);
547 ptr = msg + strlen(msg);
548 if (fstyle) {
549 for (j=0; j<ndim-1; j++) {
550 sprintf(ptr,"%d,",index[j]);
551 ptr += strlen(ptr);
552 }
553 sprintf(ptr,"%d]",index[ndim-1]);
554 ptr += strlen(ptr);
555 } else {
556 for (j=ndim-1; j>0; j++) {
557 sprintf(ptr,"%d,",index[j]);
558 ptr += strlen(ptr);
559 }
560 sprintf(ptr,"%d]",index[0]);
561 ptr += strlen(ptr);
562 }
563 sprintf(ptr,"\t corresponds to array section: ",(int)j);
564 /* for C style need to swap and decremenent by 1 both arrays */
565 if(!fstyle){
566 for(i=0; i<ndim/2; i++){
567 swap(lo+i,lo+ndim-i-1);
568 swap(hi+i,hi+ndim-i-1);
569 }
570 for(i=0; i<ndim; i++)lo[i]--;
571 for(i=0; i<ndim; i++)hi[i]--;
572 }
573 gai_print_range(msg,(int)ndim,lo,hi,"\n");
574 index[0] += proc_grid[0];
575 for (j=0; j<ndim; j++) {
576 if (index[j] >= nblocks[j] && j<ndim-1) {
577 index[j] = proc_idx[j];
578 index[j+1] += proc_grid[j+1];
579 }
580 }
581 if (index[ndim-1] >= nblocks[ndim-1]) ok = 0;
582 }
583 }
584 } else {
585 printf("\nData distribution type is unknown\n");
586 }
587 fflush(stdout);
588 }
589
590 if(local_sync_end)pnga_sync();
591 }
592
593
594 /*
595 * Jialin added nga_print and nga_print_patch on Jun 28, 1999
596 */
597
598 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
599 # pragma weak wnga_print_patch_file = pnga_print_patch_file
600 #endif
601 /*\ PRINT g_a[ilo, jlo]
602 \*/
pnga_print_patch_file(file,g_a,lo,hi,pretty)603 void pnga_print_patch_file(file, g_a, lo, hi, pretty)
604 Integer g_a, *lo, *hi, pretty;
605 FILE *file;
606 /*
607 Pretty = 0 ... spew output out with no formatting
608 Pretty = 1 ... format output so that it is readable
609 */
610 {
611 #define BUFSIZE 6
612 #define FLEN 80
613
614 Integer i, j;
615 Integer type;
616 char *name;
617 Integer ndim, dims[MAXDIM], ld[MAXDIM];
618 Integer bufsize;
619 int ibuf[BUFSIZE], ibuf_2d[BUFSIZE*BUFSIZE];
620 DoublePrecision dbuf[BUFSIZE], dbuf_2d[BUFSIZE*BUFSIZE];
621 DoublePrecision dcbuf[2*BUFSIZE], dcbuf_2d[2*BUFSIZE*BUFSIZE];
622 float fbuf[BUFSIZE], fbuf_2d[BUFSIZE*BUFSIZE];
623 float fcbuf[2*BUFSIZE], fcbuf_2d[3*BUFSIZE*BUFSIZE];
624 Integer lop[MAXDIM], hip[MAXDIM];
625 long lbuf[BUFSIZE], lbuf_2d[BUFSIZE*BUFSIZE];
626 long long llbuf[BUFSIZE], llbuf_2d[BUFSIZE*BUFSIZE];
627 Integer done, status_2d, status_3d;
628 _ga_sync_begin = 1; _ga_sync_end=1; /*remove any previous masking*/
629 pnga_sync();
630 pnga_check_handle(g_a, "nga_print");
631
632 /* only the first process print the array */
633 if(pnga_nodeid() == 0) {
634
635 pnga_inquire(g_a, &type, &ndim, dims);
636 pnga_inquire_name(g_a, &name);
637
638 /* check the boundary */
639 for(i=0; i<ndim; i++)
640 if(lo[i] <= 0 || hi[i] > dims[i])
641 pnga_error("g_a indices out of range ", g_a);
642
643 /* print the general information */
644 fprintf(file,"\n global array: %s[", name);
645 for(i=0; i<ndim; i++)
646 if(i != (ndim-1))
647 fprintf(file, "%ld:%ld,", (long)lo[i], (long)hi[i]);
648 else
649 fprintf(file, "%ld:%ld", (long)lo[i], (long)hi[i]);
650 fprintf(file,"], handle: %d \n", (int)g_a);
651
652 bufsize = (type==C_DCPL)? BUFSIZE/2 : BUFSIZE;
653 bufsize = (type==C_SCPL)? BUFSIZE/2 : BUFSIZE;
654
655 for(i=0; i<ndim; i++) ld[i] = bufsize;
656
657 if(!pretty) {
658 done = 1;
659 for(i=0; i<ndim; i++) {
660 lop[i] = lo[i]; hip[i] = lo[i];
661 }
662 hip[0] = GA_MIN(lop[0]+bufsize-1, hi[0]);
663 while(done) {
664 switch(type) {
665 case C_INT: pnga_get(g_a, lop, hip, ibuf, ld); break;
666 case C_DBL: pnga_get(g_a, lop, hip, dbuf, ld); break;
667 case C_DCPL: pnga_get(g_a, lop, hip, dcbuf, ld); break;
668 case C_FLOAT: pnga_get(g_a, lop, hip, fbuf, ld); break;
669 case C_SCPL: pnga_get(g_a, lop, hip, fcbuf, ld); break;
670 case C_LONG: pnga_get(g_a, lop, hip, lbuf, ld); break;
671 case C_LONGLONG: pnga_get(g_a, lop, hip, llbuf,ld); break;
672 default: pnga_error("ga_print: wrong type",0);
673 }
674
675 /* print the array */
676 for(i=0; i<(hip[0]-lop[0]+1); i++) {
677 fprintf(file,"%s(", name);
678 for(j=0; j<ndim; j++)
679 if((j == 0) && (j == (ndim-1)))
680 fprintf(file, "%ld", (long)lop[j]+i);
681 else if((j != 0) && (j == (ndim-1)))
682 fprintf(file, "%ld", (long)lop[j]);
683 else if((j == 0) && (j != (ndim-1)))
684 fprintf(file, "%ld,", (long)lop[j]+i);
685 else fprintf(file, "%ld,", (long)lop[j]);
686 switch(type) {
687 case C_INT:
688 fprintf(file,") = %d\n", ibuf[i]);break;
689 case C_LONG:
690 fprintf(file,") = %ld\n", lbuf[i]);break;
691 case C_LONGLONG:
692 fprintf(file,") = %lld\n", llbuf[i]);break;
693 case C_DBL:
694 if((double)dbuf[i]<100000.0)
695 fprintf(file,") = %f\n", dbuf[i]);
696 else fprintf(file,") = %e\n", dbuf[i]);
697 break;
698 case C_DCPL:
699 if(((double)dcbuf[i*2]<100000.0) &&
700 ((double)dcbuf[i*2+1]<100000.0))
701 fprintf(file,") = (%f,%f)\n",
702 dcbuf[i*2],dcbuf[i*2+1]);
703 else
704 fprintf(file,") = (%e,%e)\n",
705 dcbuf[i*2],dcbuf[i*2+1]);
706 break;
707 case C_SCPL:
708 if(((float)fcbuf[i*2]<100000.0) &&
709 ((float)fcbuf[i*2+1]<100000.0))
710 fprintf(file,") = (%f,%f)\n",
711 fcbuf[i*2],fcbuf[i*2+1]);
712 else
713 fprintf(file,") = (%e,%e)\n",
714 fcbuf[i*2],fcbuf[i*2+1]);
715 break;
716 case C_FLOAT: fprintf(file,") = %f\n", fbuf[i]);break;
717 }
718 }
719
720 fflush(file);
721
722 lop[0] = hip[0]+1; hip[0] = GA_MIN(lop[0]+bufsize-1, hi[0]);
723
724 for(i=0; i<ndim; i++) {
725 if(lop[i] > hi[i]) {
726 if(i == (ndim-1)) {
727 done = 0;
728 } else {
729 lop[i] = lo[i];
730 if(i == 0) hip[i] = GA_MIN(lop[i]+bufsize-1, hi[i]);
731 else hip[i] = lo[i];
732 lop[i+1]++; hip[i+1]++;
733 }
734 }
735 }
736 }
737 }
738 else {
739 /* pretty print */
740 done = 1;
741 for(i=0; i<ndim; i++) {
742 lop[i] = lo[i];
743 if((i == 0) || (i == 1))
744 hip[i] = GA_MIN(lop[i]+bufsize-1, hi[i]);
745 else
746 hip[i] = lo[i];
747 }
748
749 status_2d = 1; status_3d = 1;
750
751 while(done) {
752 if(status_3d && (ndim > 2)) { /* print the patch info */
753 fprintf(file,"\n -- patch: %s[", name);
754 for(i=0; i<ndim; i++)
755 if(i < 2)
756 if(i != (ndim-1))
757 fprintf(file, "%ld:%ld,", (long)lo[i], (long)hi[i]);
758 else
759 fprintf(file, "%ld:%ld", (long)lo[i], (long)hi[i]);
760 else
761 if(i != (ndim-1))
762 fprintf(file, "%ld,", (long)lop[i]);
763 else
764 fprintf(file, "%ld", (long)lop[i]);
765 fprintf(file,"]\n"); status_3d = 0;
766 }
767
768 if(status_2d &&(ndim > 1)) {
769 fprintf(file, "\n");
770 switch(type) {
771 case C_INT:
772 fprintf(file, " ");
773 for (i=lop[1]; i<=hip[1]; i++)
774 fprintf(file, "%7ld ", (long)i);
775 fprintf(file,"\n ");
776 for (i=lop[1]; i<=hip[1]; i++)
777 fprintf(file," --------");
778 break;
779 case C_LONG:
780 fprintf(file, " ");
781 for (i=lop[1]; i<=hip[1]; i++)
782 fprintf(file, "%7ld ", (long)i);
783 fprintf(file,"\n ");
784 for (i=lop[1]; i<=hip[1]; i++)
785 fprintf(file," --------");
786 break;
787 case C_LONGLONG:
788 fprintf(file, " ");
789 for (i=lop[1]; i<=hip[1]; i++)
790 fprintf(file, "%7ld ", (long)i);
791 fprintf(file,"\n ");
792 for (i=lop[1]; i<=hip[1]; i++)
793 fprintf(file," --------");
794 break;
795 case C_DBL:
796 fprintf(file, " ");
797 for (i=lop[1]; i<=hip[1]; i++)
798 fprintf(file, "%10ld ", (long)i);
799 fprintf(file,"\n ");
800 for (i=lop[1]; i<=hip[1]; i++)
801 fprintf(file," -----------");
802 break;
803 case C_DCPL:
804 for (i=lop[1]; i<=hip[1]; i++)
805 fprintf(file, "%22ld ", (long)i);
806 fprintf(file,"\n ");
807 for (i=lop[1]; i<=hip[1]; i++)
808 fprintf(file," -----------------------");
809 break;
810 case C_SCPL:
811 for (i=lop[1]; i<=hip[1]; i++)
812 fprintf(file, "%22ld ", (long)i);
813 fprintf(file,"\n ");
814 for (i=lop[1]; i<=hip[1]; i++)
815 fprintf(file," -----------------------");
816 break;
817 case C_FLOAT:
818 fprintf(file, " ");
819 for (i=lop[1]; i<=hip[1]; i++)
820 fprintf(file, "%7ld ", (long)i);
821 fprintf(file,"\n ");
822 for (i=lop[1]; i<=hip[1]; i++)
823 fprintf(file," --------");
824 break;
825 default:
826 pnga_error("ga_print: wrong type", 0);
827 }
828
829 fprintf(file,"\n");
830 status_2d = 0;
831 }
832
833 switch(type) {
834 case C_INT: pnga_get(g_a, lop, hip, ibuf_2d, ld); break;
835 case C_LONG: pnga_get(g_a, lop, hip,lbuf_2d, ld); break;
836 case C_LONGLONG: pnga_get(g_a, lop, hip,llbuf_2d,ld);break;
837 case C_DBL: pnga_get(g_a, lop, hip, dbuf_2d, ld); break;
838 case C_DCPL: pnga_get(g_a, lop, hip, dcbuf_2d, ld);break;
839 case C_FLOAT: pnga_get(g_a, lop, hip, fbuf_2d, ld);break;
840 case C_SCPL: pnga_get(g_a, lop, hip, fcbuf_2d, ld);break;
841 default: pnga_error("ga_print: wrong type",0);
842 }
843
844 for(i=0; i<(hip[0]-lop[0]+1); i++) {
845 fprintf(file,"%4ld ", (long)(lop[0]+i));
846 switch(type) {
847 case C_INT:
848 if(ndim > 1)
849 for(j=0; j<(hip[1]-lop[1]+1); j++)
850 fprintf(file," %8d", ibuf_2d[j*bufsize+i]);
851 else fprintf(file," %8d", ibuf_2d[i]);
852 break;
853 case C_LONG:
854 if(ndim > 1)
855 for(j=0; j<(hip[1]-lop[1]+1); j++)
856 fprintf(file," %8ld",lbuf_2d[j*bufsize+i]);
857 else fprintf(file," %8ld",lbuf_2d[i]);
858 break;
859 case C_LONGLONG:
860 if(ndim > 1)
861 for(j=0; j<(hip[1]-lop[1]+1); j++)
862 fprintf(file," %8lld",llbuf_2d[j*bufsize+i]);
863 else fprintf(file," %8lld",llbuf_2d[i]);
864 break;
865 case C_DBL:
866 if(ndim > 1)
867 for(j=0; j<(hip[1]-lop[1]+1); j++)
868 if((double)dbuf_2d[j*bufsize+i]<100000.0)
869 fprintf(file," %11.5f",
870 dbuf_2d[j*bufsize+i]);
871 else
872 fprintf(file," %.5e",
873 dbuf_2d[j*bufsize+i]);
874 else
875 if((double)dbuf_2d[i]<100000.0)
876 fprintf(file," %11.5f",dbuf_2d[i]);
877 else
878 fprintf(file," %.5e",dbuf_2d[i]);
879 break;
880 case C_FLOAT:
881 if(ndim > 1)
882 for(j=0; j<(hip[1]-lop[1]+1); j++)
883 fprintf(file," %11.5f", fbuf_2d[j*bufsize+i]);
884 else fprintf(file," %11.5f", fbuf_2d[i]);
885 break;
886 case C_DCPL:
887 if(ndim > 1)
888 for(j=0; j<(hip[1]-lop[1]+1); j++)
889 if(((double)dcbuf_2d[(j*bufsize+i)*2]<100000.0)&&((double)dcbuf_2d[(j*bufsize+i)*2+1]<100000.0))
890 fprintf(file," %11.5f,%11.5f",
891 dcbuf_2d[(j*bufsize+i)*2],
892 dcbuf_2d[(j*bufsize+i)*2+1]);
893 else
894 fprintf(file," %.5e,%.5e",
895 dcbuf_2d[(j*bufsize+i)*2],
896 dcbuf_2d[(j*bufsize+i)*2+1]);
897 else
898 if(((double)dcbuf_2d[i*2]<100000.0) &&
899 ((double)dcbuf_2d[i*2+1]<100000.0))
900 fprintf(file," %11.5f,%11.5f",
901 dcbuf_2d[i*2], dcbuf_2d[i*2+1]);
902 else
903 fprintf(file," %.5e,%.5e",
904 dcbuf_2d[i*2], dcbuf_2d[i*2+1]);
905 break;
906 case C_SCPL:
907 if(ndim > 1)
908 for(j=0; j<(hip[1]-lop[1]+1); j++)
909 if(((float)fcbuf_2d[(j*bufsize+i)*2]<100000.0)&&((float)fcbuf_2d[(j*bufsize+i)*2+1]<100000.0))
910 fprintf(file," %11.5f,%11.5f",
911 fcbuf_2d[(j*bufsize+i)*2],
912 fcbuf_2d[(j*bufsize+i)*2+1]);
913 else
914 fprintf(file," %.5e,%.5e",
915 fcbuf_2d[(j*bufsize+i)*2],
916 fcbuf_2d[(j*bufsize+i)*2+1]);
917 else
918 if(((float)fcbuf_2d[i*2]<100000.0) &&
919 ((float)fcbuf_2d[i*2+1]<100000.0))
920 fprintf(file," %11.5f,%11.5f",
921 fcbuf_2d[i*2], fcbuf_2d[i*2+1]);
922 else
923 fprintf(file," %.5e,%.5e",
924 fcbuf_2d[i*2], fcbuf_2d[i*2+1]);
925 break;
926 default:
927 pnga_error("ga_print: wrong data type", 0);
928 }
929
930 fprintf(file,"\n");
931 }
932
933 lop[0] = hip[0]+1; hip[0] = GA_MIN(lop[0]+bufsize-1, hi[0]);
934
935 for(i=0; i<ndim; i++) {
936 if(lop[i] > hi[i]) {
937 if(i == (ndim-1)) {
938 done = 0;
939 } else {
940 lop[i] = lo[i];
941
942 if((i == 0) || (i == 1)) {
943 hip[i] = GA_MIN(lop[i]+bufsize-1, hi[i]);
944 } else {
945 hip[i] = lo[i];
946 }
947
948 if(i == 0) {
949 lop[i+1] = hip[i+1]+1;
950 hip[i+1] = GA_MIN(lop[i+1]+bufsize-1, hi[i+1]);
951 } else {
952 lop[i+1]++; hip[i+1]++;
953 }
954
955 if(i == 0) status_2d = 1;
956 if(i == 1) status_3d = 1;
957 }
958 }
959 }
960 }
961 }
962 fflush(file);
963 }
964
965 pnga_sync();
966 }
967
968 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
969 # pragma weak wnga_print_patch = pnga_print_patch
970 #endif
pnga_print_patch(Integer g_a,Integer * lo,Integer * hi,Integer pretty)971 void pnga_print_patch(Integer g_a, Integer *lo, Integer *hi, Integer pretty)
972 {
973 pnga_print_patch_file(stdout, g_a, lo, hi, pretty);
974
975 }
976
977 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
978 # pragma weak wnga_summarize = pnga_summarize
979 #endif
pnga_summarize(Integer verbose)980 void pnga_summarize(Integer verbose)
981 {
982 #define DEV stdout
983
984 Integer i, j, g_a;
985 Integer printed, arr_no;
986 Integer type, active;
987 char *name;
988 Integer ndim, dims[MAXDIM];
989 Integer lop[MAXDIM], hip[MAXDIM];
990 Integer nproc = pnga_nnodes();
991
992 fprintf(DEV, " Summary of allocated global arrays\n");
993 fprintf(DEV, "-----------------------------------\n");
994
995 printed = 0;
996 arr_no = 0;
997
998 for(g_a=-1000; g_a<-900; g_a++) {
999 active = pnga_verify_handle(g_a);
1000
1001 if(active == 1) {
1002 printed = 1;
1003 pnga_inquire(g_a, &type, &ndim, dims);
1004 pnga_inquire_name(g_a, &name);
1005
1006 switch(type) {
1007 case C_INT:
1008 fprintf(DEV, " array %d => integer ", (int)arr_no);
1009 break;
1010 case C_DBL:
1011 fprintf(DEV, " array %d => double precision ",(int)arr_no);
1012 break;
1013 case C_DCPL:
1014 fprintf(DEV, " array %d => double complex ", (int)arr_no);
1015 break;
1016 case C_SCPL:
1017 fprintf(DEV, " array %d => float (single) complex ", (int)arr_no);
1018 break;
1019 case C_FLOAT:
1020 fprintf(DEV, " array %d => float ",(int)arr_no);
1021 break;
1022 case C_LONG:
1023 fprintf(DEV, " array %d => long ",(int)arr_no);
1024 break;
1025 case C_LONGLONG:
1026 fprintf(DEV, " array %d => long long",(int)arr_no);
1027 break;
1028 default: pnga_error("ga_print: wrong type",0);
1029 }
1030 arr_no++;
1031
1032 fprintf(DEV,"%s(", name);
1033 for(i=0; i<ndim; i++)
1034 if(i != (ndim-1)) fprintf(DEV, "%ld,", (long)dims[i]);
1035 else fprintf(DEV, "%ld", (long)dims[i]);
1036 fprintf(DEV,"), handle: %d \n",(int) g_a);
1037
1038 if(verbose) {
1039 for(i=0; i<nproc; i++){
1040 pnga_distribution(g_a, i, lop, hip);
1041
1042 fprintf(DEV," (");
1043 for(j=0; j<ndim; j++)
1044 if(j != (ndim-1))
1045 fprintf(DEV, "%ld:%ld,",(long)lop[j], (long)hip[j]);
1046 else
1047 fprintf(DEV, "%ld:%ld", (long)lop[j], (long)hip[j]);
1048 fprintf(DEV,") -> %d \n",(int) i);
1049 }
1050 }
1051 }
1052 }
1053
1054 if(!printed) fprintf(DEV, " No active global arrays\n");
1055
1056 fprintf(DEV, "\n\n");
1057 fflush(DEV);
1058 }
1059
1060 #endif
1061
1062 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1063 # pragma weak wnga_print_file = pnga_print_file
1064 #endif
pnga_print_file(FILE * file,Integer g_a)1065 void pnga_print_file(FILE *file, Integer g_a)
1066 {
1067 Integer i;
1068 Integer type, ndim, dims[MAXDIM];
1069 Integer lo[MAXDIM];
1070 Integer pretty = 1;
1071
1072 pnga_inquire(g_a, &type, &ndim, dims);
1073
1074 for(i=0; i<ndim; i++) lo[i] = 1;
1075
1076 pnga_print_patch_file(file, g_a, lo, dims, pretty);
1077 }
1078
1079
1080 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1081 # pragma weak wnga_print = pnga_print
1082 #endif
pnga_print(Integer g_a)1083 void pnga_print(Integer g_a)
1084 {
1085 pnga_print_file(stdout, g_a);
1086 }
1087
1088
1089 /*\ return ClusterNode id of the specified process
1090 \*/
1091 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1092 # pragma weak wnga_cluster_proc_nodeid = pnga_cluster_proc_nodeid
1093 #endif
pnga_cluster_proc_nodeid(Integer proc)1094 Integer pnga_cluster_proc_nodeid(Integer proc)
1095 {
1096 return (Integer) armci_domain_id(ARMCI_DOMAIN_SMP, (int)proc);
1097 }
1098
1099 /*\ return ClusterNode id of the calling process
1100 \*/
1101 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1102 # pragma weak wnga_cluster_nodeid = pnga_cluster_nodeid
1103 #endif
pnga_cluster_nodeid()1104 Integer pnga_cluster_nodeid()
1105 {
1106 return (Integer) armci_domain_my_id(ARMCI_DOMAIN_SMP);
1107 }
1108
1109 /*\ number of nodes in a cluster
1110 \*/
1111 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1112 # pragma weak wnga_cluster_nnodes = pnga_cluster_nnodes
1113 #endif
pnga_cluster_nnodes()1114 Integer pnga_cluster_nnodes()
1115 {
1116 return (Integer) armci_domain_count(ARMCI_DOMAIN_SMP);
1117 }
1118
1119 /*\ number of processes in the job on the specified node
1120 \*/
1121 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1122 # pragma weak wnga_cluster_nprocs = pnga_cluster_nprocs
1123 #endif
pnga_cluster_nprocs(Integer node)1124 Integer pnga_cluster_nprocs(Integer node)
1125 {
1126 return (Integer) armci_domain_nprocs(ARMCI_DOMAIN_SMP, (int)node);
1127 }
1128
1129
1130 /*\ global id of corresponding to node and local process ids
1131 \*/
1132 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1133 # pragma weak wnga_cluster_procid = pnga_cluster_procid
1134 #endif
pnga_cluster_procid(Integer node,Integer loc_proc_id)1135 Integer pnga_cluster_procid(Integer node, Integer loc_proc_id)
1136 {
1137 return (Integer) armci_domain_glob_proc_id(ARMCI_DOMAIN_SMP, (int)node,
1138 (int)loc_proc_id);
1139 }
1140
1141 #ifdef MSG_COMMS_MPI
1142 # include <mpi.h>
1143 #else
1144 # include "tcgmsg.h"
1145 #endif
1146 /*\ wrapper for wallclock timer. Returns an alapsed time on calling process
1147 \*/
1148 #if HAVE_SYS_WEAK_ALIAS_PRAGMA
1149 # pragma weak wnga_wtime = pnga_wtime
1150 #endif
pnga_wtime()1151 DoublePrecision pnga_wtime()
1152 {
1153 double wtime=0.0;
1154 #ifdef MSG_COMMS_MPI
1155 wtime = MPI_Wtime();
1156 #else
1157 wtime = tcg_time();
1158 #endif
1159 return (DoublePrecision)wtime;
1160 }
1161