/* Complex absolute value */
int
ar_cabs (ar_data *result, const AR_TYPE *resulttype,
const ar_data *opnd, const AR_TYPE *opndtype)
{
int status;
ar_data re, im, resq, imsq, sum, nat_opnd, nat_result;
AR_TYPE reimtype;
#if defined(complex_t)
if (*resulttype == native_double &&
*opndtype == native_complex) {
*(double_t *) result = (cabs) (*(complex_t *) opnd);
return AR_status((AR_DATA*)result, resulttype);
}
/* The operation is not a native library operation.
* Convert, execute, and convert back.
*/
status = AR_convert ((AR_DATA*)&nat_opnd, &native_complex,
(AR_DATA*)opnd, opndtype);
status |= ar_cabs (&nat_result, &native_round_single,
&nat_opnd, &native_complex);
status &= ~(AR_NEGATIVE | AR_ZERO);
status |= AR_convert ((AR_DATA*)result, resulttype,
(AR_DATA*)&nat_result, &native_round_single);
#else
/* If no native complex operations, compute sqrt (real**2 * imag**2). */
status = ar_decompose_complex (&re, &im, &reimtype,
opnd, opndtype);
status |= AR_multiply ((AR_DATA*)&resq, &reimtype,
(AR_DATA*)&re, &reimtype,
(AR_DATA*)&re, &reimtype);
status |= AR_multiply ((AR_DATA*)&imsq, &reimtype,
(AR_DATA*)&im, &reimtype,
(AR_DATA*)&im, &reimtype);
status |= AR_add ((AR_DATA*)&sum, &reimtype,
(AR_DATA*)&resq, &reimtype,
(AR_DATA*)&imsq, &reimtype);
status &= ~(AR_STAT_ZERO | AR_STAT_NEGATIVE);
status |= AR_sqrt ((AR_DATA*)result, resulttype, (AR_DATA*)&sum, &reimtype);
#endif
return status;
}
main() {
AR_HOST_SINT64 ans[4];
AR_HOST_SINT64 arg[8];
AR_HOST_SINT64 result[4];
AR_TYPE rtype,opndtype,ptype;
char line[256];
char prevfunc[9];
char func[9];
char* linep;
char* num;
int i,l,n;
int sum,xor;
int ierr;
int pass,okerrs,fail;
int rsize;
FILE *file;
pass=okerrs=fail=0;
file = fopen("results/cray1_sim_data","r");
if(file == NULL) {
fprintf(stderr, "Could not open results/cray1_sim_data\n");
exit(0);
}
prevfunc[0]=0;
while(fgets(line,256,file) != NULL) {
i=l=0;
while(line[l] != '(')
func[i++]=line[l++];
func[i]=0;
if(strcmp(func,"STOP") == 0) exit(0);
if(strcmp(func,prevfunc)) {
printf("Testing %s intrinsic\n",func);
strcpy(prevfunc,func);
}
l++;
num=NULL;
if(func[0]=='C') {
if(func[1]=='D')
if(strcmp(func,"CDABS") != 0)
rsize=4;
else
rsize=2;
else if(strcmp(func,"CABS")!=0 && strcmp(func,"COS")!=0)
rsize=2;
else
rsize=1;
}
else if(func[0]=='D')
rsize=2;
else if(strcmp(func,"STRTOD") == 0) {
rsize=1;
num=line+l;
}
else if(strcmp(func,"STRTOLD") == 0) {
rsize=2;
num=line+l;
}
else if(strcmp(func,"MODULOD") == 0)
rsize=2;
else
rsize=1;
n=0;
while(line[l] != ')') {
if(num == NULL) {
if(line[l]=='C') {
if(line[++l]=='D')
{ n+=4; l++; }
else
n+=2;
}
else if(line[l++]=='D')
n+=2;
else
n+=1;
if(line[l]==',')
l++;
else if(line[l]!=')') {
fprintf(stderr,"Invalid input on line:\n %s\n",line);
n=0;
break;
}
}
else {
n=1;
l++;
}
}
if(n == 0) continue;
linep=&line[++l];
if(num == NULL) {
for(i=0;i<n;i++)
get_hex_input(&linep, &arg[i]);
}
else {
line[l-1] = 0;
memcpy((char*)(&arg[0])+8-sizeof(char*), &num, sizeof(char*));
}
for(i=0;i<rsize;i++)
get_hex_input(&linep, &ans[i]);
l = strlen(func);
if(strncmp(func,"STRTO",5) == 0) {
if(func[5] == 'D')
rtype = AR_Float_Cray1_64;
else
rtype = AR_Float_Cray1_128;
ierr=AR_convert_str_to_float((AR_DATA*)&result[0], &rtype, num);
num[strlen(num)] = ')';
}
else if(strncmp(&func[l-3],"LOG",3) == 0) {
if(func[0] == 'A')
rtype = AR_Float_Cray1_64;
else if(func[0] == 'D')
rtype = AR_Float_Cray1_128;
else if(func[1] == 'L')
rtype = AR_Complex_Cray1_64;
else
rtype = AR_Complex_Cray1_128;
ierr = AR_log((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &rtype);
}
else if(strncmp(&func[l-3],"EXP",3) == 0) {
if(func[0] == 'E')
rtype = AR_Float_Cray1_64;
else if(func[0] == 'D')
rtype = AR_Float_Cray1_128;
else if(func[1] == 'E')
rtype = AR_Complex_Cray1_64;
else
rtype = AR_Complex_Cray1_128;
ierr = AR_exp((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &rtype);
}
else if(strncmp(&func[l-4],"SQRT",4) == 0) {
if(func[0] == 'S')
rtype = AR_Float_Cray1_64;
else if(func[0] == 'D')
rtype = AR_Float_Cray1_128;
else if(func[1] == 'S')
rtype = AR_Complex_Cray1_64;
else
rtype = AR_Complex_Cray1_128;
ierr = AR_sqrt((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &rtype);
}
else if(strncmp(&func[l-3],"ABS",3) == 0) {
if(func[1] == 'A') {
rtype = AR_Float_Cray1_64;
opndtype = AR_Complex_Cray1_64;
}
else {
rtype = AR_Float_Cray1_128;
opndtype = AR_Complex_Cray1_128;
}
ierr = AR_cabs((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &opndtype);
}
else if(strncmp(&func[l-3],"TOI",3)==0 ||
strncmp(&func[l-3],"TOR",3)==0) {
if(func[0] == 'I') {
rtype = AR_Int_64_S;
opndtype = AR_Int_64_S;
}
else if(func[0] == 'R') {
rtype = AR_Float_Cray1_64;
opndtype = AR_Float_Cray1_64;
}
else if(func[0] == 'D') {
rtype = AR_Float_Cray1_128;
opndtype = AR_Float_Cray1_128;
}
else if(func[1] == 'T') {
rtype = AR_Complex_Cray1_64;
opndtype = AR_Complex_Cray1_64;
}
else {
rtype = AR_Complex_Cray1_128;
opndtype = AR_Complex_Cray1_128;
}
if(func[l-1] == 'I')
ptype = AR_Int_64_S;
else
ptype = AR_Float_Cray1_64;
ierr = AR_power((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &opndtype, (AR_DATA*)&arg[n-1], &ptype);
}
else if(strncmp(&func[0],"MODULO",6)==0 ) {
if(func[6] == 'I')
rtype = AR_Int_46_S;
else if(func[6] == 'J')
rtype = AR_Int_64_S;
else if(func[6] == 'S')
rtype = AR_Float_Cray1_64;
else if(func[6] == 'D')
rtype = AR_Float_Cray1_128;
ierr = AR_Modulo((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &rtype, (AR_DATA*)&arg[n>>1], &rtype);
}
else if(strncmp(&func[0],"SELREALK",8)==0 ) {
rtype = AR_Int_64_S;
if(arg[0] < 0 && arg[1] < 0)
ierr = AR_selected_real_kind((AR_DATA*)&result[0], &rtype, (AR_DATA*)NULL, &rtype, (AR_DATA*)NULL, &rtype);
else if(arg[0] < 0)
ierr = AR_selected_real_kind((AR_DATA*)&result[0], &rtype, (AR_DATA*)NULL, &rtype, (AR_DATA*)&arg[1], &rtype);
else if(arg[1] < 0)
ierr = AR_selected_real_kind((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &rtype, (AR_DATA*)NULL, &rtype);
else
ierr = AR_selected_real_kind((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &rtype, (AR_DATA*)&arg[1], &rtype);
}
else {
if(func[0] == 'D') {
rtype = AR_Float_Cray1_128;
opndtype = AR_Float_Cray1_128;
ptype = AR_Float_Cray1_128;
}
else if(func[1] == 'T') {
rtype = AR_Complex_Cray1_64;
opndtype = AR_Complex_Cray1_64;
ptype = AR_Complex_Cray1_64;
}
else {
rtype = AR_Complex_Cray1_128;
opndtype = AR_Complex_Cray1_128;
ptype = AR_Complex_Cray1_128;
}
ierr = AR_power((AR_DATA*)&result[0], &rtype, (AR_DATA*)&arg[0], &opndtype, (AR_DATA*)&arg[n>>1], &ptype);
}
ierr &= (AR_STAT_OVERFLOW|AR_STAT_UNDERFLOW|AR_STAT_UNDEFINED|AR_STAT_INVALID_TYPE);
for(xor=0, i=0; i<rsize; i++)
xor |= (result[i]^ans[i]);
if(ierr!=0 || xor!=0) {
if(ierr!=0 && ans[0]==ierr)
okerrs++;
else {
fprintf(stderr,"\n***** ERROR *** ERROR *** ERROR *** ERROR *****\n");
fprintf(stderr," Intrinsic result does not match expected result on input line:\n %s\n",line);
if(ierr != 0)
fprintf(stderr," The intrinsic returned an error code = 0%o\n",ierr);
else {
fprintf(stderr," The intrinsic returned a result of:\n ");
for(i=0; i<rsize; i++)
fprintf(stderr," %8.8x %8.8x",result[i]);
fprintf(stderr,"\n");
}
fail++;
}
}
else
pass++;
}
