1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
/* ---------------------------------------------------------------------
*
* -- PBLAS auxiliary routine (version 2.0) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
* April 1, 1998
*
* ---------------------------------------------------------------------
*/
/*
* Include files
*/
#ifdef TestingPblas
#include "../SRC/pblas.h"
#include "../SRC/PBpblas.h"
#include "../SRC/PBtools.h"
#include "../SRC/PBblacs.h"
#include "../SRC/PBblas.h"
#else
#include "../pblas.h"
#include "../PBpblas.h"
#include "../PBtools.h"
#include "../PBblacs.h"
#include "../PBblas.h"
#endif
/*
* ---------------------------------------------------------------------
* FORTRAN <-> C interface
* ---------------------------------------------------------------------
*
* These macros identifies how the PBLAS will be called as follows:
*
* _F2C_ADD_: the FORTRAN compiler expects the name of C functions to be
* in all lower case and to have an underscore postfixed it (Suns, Intel
* compilers expect this).
*
* _F2C_NOCHANGE: the FORTRAN compiler expects the name of C functions
* to be in all lower case (IBM RS6K compilers do this).
*
* _F2C_UPCASE: the FORTRAN compiler expects the name of C functions
* to be in all upcase. (Cray compilers expect this).
*
* _F2C_F77ISF2C: the FORTRAN compiler in use is f2c, a FORTRAN to C
* converter.
*/
#if (_F2C_CALL_ == _F2C_ADD_ )
#define PB_NoAbort pb_noabort_
#endif
#if (_F2C_CALL_ == _F2C_UPCASE )
#define PB_NoAbort PB_NOABORT
#endif
#if (_F2C_CALL_ == _F2C_NOCHANGE )
#define PB_NoAbort pb_noabort
#endif
#if (_F2C_CALL_ == _F2C_F77ISF2C )
#define PB_NoAbort pb_noabort__
#endif
#ifdef __STDC__
void PB_Cabort( int ICTXT, char * ROUT, int INFO )
#else
void PB_Cabort( ICTXT, ROUT, INFO )
/*
* .. Scalar Arguments ..
*/
int ICTXT, INFO;
/*
* .. Array Arguments ..
*/
char * ROUT;
#endif
{
/*
* Purpose
* =======
*
* PB_Cabort is an error handler for the PBLAS routines. This routine
* displays an error message on stderr by calling PB_Cwarn, and halts
* execution by calling Cblacs_abort().
*
* Arguments
* =========
*
* ICTXT (local input) INTEGER
* On entry, ICTXT specifies the BLACS context handle, indica-
* ting the global context of the operation. The context itself
* is global, but the value of ICTXT is local.
*
* ROUT (global input) pointer to CHAR
* On entry, ROUT specifies the name of the routine calling this
* error handler.
*
* INFO (local input) INTEGER
* The error code computed by the calling PBLAS routine.
* = 0: no error found
* < 0: If the i-th argument is an array and the j-entry had
* an illegal value, then INFO = -(i*100+j), if the i-th
* argument is a scalar and had an illegal value, then
* INFO = -i.
*
* -- Written on April 1, 1998 by
* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
*
* ---------------------------------------------------------------------
*/
/*
* .. Local Scalars ..
*/
int mycol, myrow, npcol, nprow;
/* ..
* .. External Functions ..
*/
#ifdef TestingPblas
#ifdef __STDC__
int PB_NoAbort( int * );
#else
int PB_NoAbort();
#endif
#endif
/* ..
* .. Executable Statements ..
*
*/
Cblacs_gridinfo( ICTXT, &nprow, &npcol, &myrow, &mycol );
#ifdef TestingPblas
/*
* For testing purpose only, the error is reported, but the program execution
* is not terminated
*/
if( PB_NoAbort( &INFO ) ) return;
#endif
if( INFO < 0 )
{
/*
* Display an error message
*/
if( INFO < DESCMULT )
PB_Cwarn( ICTXT, -1, ROUT,
"Parameter number %d had an illegal value", -INFO );
else
PB_Cwarn( ICTXT, -1, ROUT,
"Parameter number %d, entry number %d had an illegal value",
(-INFO) / DESCMULT, (-INFO) % DESCMULT );
}
else
{
/*
* Error code is incorrect, it should be negative
*/
PB_Cwarn( ICTXT, -1, ROUT,
"Positive error code %d returned by %s!!!", INFO );
}
Cblacs_abort( ICTXT, INFO );
/*
* End of PB_Cabort
*/
}
|
