File indexing completed on 2023-05-28 05:10:55 UTC
view on githubraw file Latest commit b4daa243 on 2023-05-28 03:53:22 UTC
b4daa24319 Shre*0001
0002
0003
0004
0005
0006
0007
0008 #include <string.h>
0009 #include <stdio.h>
0010 #include <stdlib.h>
0011 #include <sys/types.h>
0012 #include <sys/stat.h>
0013 #include <errno.h>
0014 #include <math.h>
0015 #include "adDebug.h"
0016
0017
0018
0019
0020
0021 extern void pushNArray(char *x, unsigned int nbChars, int checkReadOnly) ;
0022 extern void popNArray(char *x, unsigned int nbChars, int checkReadOnly) ;
0023 extern void pushCharacterArray(char *x, int n) ;
0024 extern void popCharacterArray(char *x, int n) ;
0025
0026
0027
0028 typedef struct _DBAD_CallStackElem {
0029 char *funcname ;
0030 int deltadepth ;
0031 int code ;
0032 struct _DBAD_CallStackElem *context ;
0033 } DBAD_CallStackElem ;
0034
0035 static DBAD_CallStackElem dbad_topContext ;
0036 static DBAD_CallStackElem *dbad_callStack ;
0037 static int dbad_calltracedepth = 1 ;
0038
0039 static int dbad_mode, dbad_phase, dbad_nberrors ;
0040 static int dbad_trace = 0 ;
0041 static int dbad_nocommunication = 0 ;
0042
0043
0044
0045 static int dbad_testThisProcess = -1 ;
0046 static FILE *dbad_file ;
0047 static double dbad_errormax, dbad_ddeps = 1.e-6 ;
0048 static double dbad_seed = 0.137 ;
0049 static double dbad_currentSeed = 0.0 ;
0050 static double dbad_condensed_dd, dbad_condensed_tgt, dbad_condensed_adj ;
0051 static double dbad_refsum, dbad_nextrefsum ;
0052
0053
0054 static double dbad_adr8buf[512] ;
0055 static int dbad_adr8ibuf = 0 ;
0056 static int dbad_adi4buf[512] ;
0057 static int dbad_adi4ibuf = 0 ;
0058
0059 void dbad_pushReal8(double x) {
0060 if (dbad_adr8ibuf >= 511) {
0061 dbad_adr8buf[511] = x ;
0062 pushNArray((char *)dbad_adr8buf, 512*8, 1) ;
0063 dbad_adr8ibuf = 0 ;
0064 } else {
0065 dbad_adr8buf[dbad_adr8ibuf] = x ;
0066 ++dbad_adr8ibuf ;
0067 }
0068 }
0069
0070 void dbad_popReal8(double *x) {
0071 if (dbad_adr8ibuf <= 0) {
0072 popNArray((char *)dbad_adr8buf, 512*8, 1) ;
0073 dbad_adr8ibuf = 511 ;
0074 *x = dbad_adr8buf[511] ;
0075 } else {
0076 --dbad_adr8ibuf ;
0077 *x = dbad_adr8buf[dbad_adr8ibuf] ;
0078 }
0079 }
0080
0081 void dbad_pushinteger4(int x) {
0082 if (dbad_adi4ibuf >= 511) {
0083 dbad_adi4buf[511] = x ;
0084 pushNArray((char *)dbad_adi4buf, 512*4, 1) ;
0085 dbad_adi4ibuf = 0 ;
0086 } else {
0087 dbad_adi4buf[dbad_adi4ibuf] = x ;
0088 ++dbad_adi4ibuf ;
0089 }
0090 }
0091
0092 void dbad_popinteger4(int *x) {
0093 if (dbad_adi4ibuf <= 0) {
0094 popNArray((char *)dbad_adi4buf, 512*4, 1) ;
0095 dbad_adi4ibuf = 511 ;
0096 *x = dbad_adi4buf[511] ;
0097 } else {
0098 --dbad_adi4ibuf ;
0099 *x = dbad_adi4buf[dbad_adi4ibuf] ;
0100 }
0101 }
0102
0103
0104 void dbad_pushCallFrame(char* unitname, int deltadepth, int forcetraced) {
0105 DBAD_CallStackElem *newCallLevel = (DBAD_CallStackElem*)malloc(sizeof(DBAD_CallStackElem)) ;
0106 newCallLevel->funcname = (char*)malloc(100) ;
0107 sprintf(newCallLevel->funcname, "%s", unitname) ;
0108 newCallLevel->deltadepth = (dbad_calltracedepth>0?1-deltadepth:0) ;
0109 dbad_calltracedepth -= newCallLevel->deltadepth ;
0110
0111 if (forcetraced>0 && forcetraced>dbad_calltracedepth) {
0112 newCallLevel->deltadepth -= (forcetraced-dbad_calltracedepth) ;
0113 dbad_calltracedepth = forcetraced ;
0114 }
0115 newCallLevel->code = 0 ;
0116 newCallLevel->context = dbad_callStack ;
0117 dbad_callStack = newCallLevel ;
0118 }
0119
0120 void dbad_popCallFrame() {
0121 dbad_calltracedepth += dbad_callStack->deltadepth ;
0122 DBAD_CallStackElem *newCallLevel = dbad_callStack->context ;
0123 free(dbad_callStack->funcname) ;
0124 free(dbad_callStack) ;
0125 dbad_callStack = newCallLevel ;
0126 }
0127
0128 int dbad_debughere(int forcetraced) {
0129 return (dbad_calltracedepth>0 || forcetraced) ;
0130 }
0131
0132 int dbad_debugabove() {
0133 return (dbad_calltracedepth+dbad_callStack->deltadepth)>0 ;
0134 }
0135
0136 int dbad_callstackdepth() {
0137 DBAD_CallStackElem *incallstack = dbad_callStack ;
0138 int depth = 0 ;
0139 while (incallstack) {++depth ; incallstack=incallstack->context ;}
0140 return depth-1 ;
0141 }
0142
0143 void dbad_resetCondensors() {
0144 dbad_currentSeed = 0.0 ;
0145 dbad_condensed_dd = 0.0 ;
0146 dbad_condensed_tgt = 0.0 ;
0147 dbad_condensed_adj = 0.0 ;
0148 }
0149
0150 double dbad_nextRandom() {
0151 dbad_currentSeed += dbad_seed ;
0152 if (dbad_currentSeed>=1.0) dbad_currentSeed-=1.0 ;
0153
0154 return dbad_currentSeed+1.0 ;
0155 }
0156
0157
0158
0159 void dbad_scaleIndepDirection4(float *indepd, float indep) {
0160 int exponent ;
0161 frexpf(indep, &exponent);
0162 *indepd = ldexpf(*indepd, exponent) ;
0163 }
0164
0165
0166
0167 void dbad_scaleIndepDirection8(double *indepd, double indep) {
0168 int exponent ;
0169 frexp(indep, &exponent);
0170 *indepd = ldexp(*indepd, exponent) ;
0171 }
0172
0173 void dbad_putOneVarName(char *varname) {
0174 char buf[8]=" " ;
0175 int len = strlen(varname) ;
0176 if (len>8) len = 8 ;
0177 memcpy(buf, varname, len) ;
0178 fwrite(buf, sizeof(char), 8, dbad_file) ;
0179 }
0180
0181 void dbad_ddcheckvarname(char* varname) {
0182 char localBuf[9]=" " ;
0183 char remoteBuf[9]=" " ;
0184 int len = strlen(varname) ;
0185 if (len>8) len = 8 ;
0186 memcpy(localBuf, varname, len) ;
0187 fread(remoteBuf, sizeof(char), 8, dbad_file) ;
0188 if (strcmp(localBuf, remoteBuf)!=0) {
0189 printf("Control mismatch, expecting a variable named \"%s\", got \"%s\"\n",localBuf,remoteBuf) ;
0190 exit(0) ;
0191 }
0192 }
0193
0194 void dbad_putOne8(double var) {
0195 fwrite(&var, sizeof(double), 1, dbad_file) ;
0196 }
0197
0198 void dbad_putOne4(float var) {
0199 float fl2[2] ;
0200 fl2[0] = var ;
0201 fwrite(fl2, sizeof(float), 2, dbad_file) ;
0202 }
0203
0204 void dbad_getOne8(double *var) {
0205 fread(var, sizeof(double), 1, dbad_file) ;
0206 }
0207
0208 void dbad_getOne4(float *var) {
0209 float fl2[2] ;
0210 fread(fl2, sizeof(float), 2, dbad_file) ;
0211 *var = fl2[0] ;
0212 }
0213
0214
0215
0216 int dbad_discrepancy8(double vareps, double var, double vard, double *dd, float *diff) {
0217 int hasDifference = 0 ;
0218 int almostZero = -15;
0219 int errMaxBits = 8;
0220 int trustableMantissa = 53;
0221 *dd = 0.0 ;
0222
0223 int expoTG ;
0224 frexp(vard, &expoTG) ;
0225 double dv = vareps-var ;
0226
0227 if (dv==0.0) {
0228 *dd = 0.0 ;
0229 if (vard==0.0 || expoTG<almostZero) {
0230 hasDifference = 0 ;
0231 *diff = 0.0 ;
0232 } else {
0233 hasDifference = 1;
0234 *diff = 100.0;
0235
0236
0237
0238
0239 }
0240 } else {
0241 *dd = dv/dbad_ddeps ;
0242 int expoDD ;
0243 frexpf(*dd, &expoDD) ;
0244 double hv = dv - dbad_ddeps*vard ;
0245
0246 if (hv==0.0 || expoTG<almostZero || expoDD<almostZero) {
0247 hasDifference = 0 ;
0248 *diff = 0.0 ;
0249 } else {
0250 int expoDV, expoV1, expoV2, expoV, expoHV ;
0251 frexp(dv, &expoDV) ;
0252 frexp(var, &expoV1) ;
0253 frexp(vareps, &expoV2) ;
0254 expoV = (var==0.0?expoV2:(vareps==0?expoV1:(expoV1>expoV2?expoV1:expoV2))) ;
0255 frexp(hv, &expoHV) ;
0256 int discrepancySmallness = expoDV-expoHV ;
0257 int discrepancyExactness = trustableMantissa-expoV+expoDV ;
0258 hasDifference = (discrepancySmallness<errMaxBits && discrepancySmallness<discrepancyExactness) ;
0259
0260 double absvard = (vard>=0.0?vard:-vard) ;
0261 double absdd = (*dd>=0.0?*dd:-*dd) ;
0262 double maxabs = (absvard>absdd?absvard:absdd) ;
0263 double absvardmdd = vard-*dd ;
0264 if (absvardmdd<0.0) absvardmdd=-absvardmdd ;
0265 *diff = (float)((absvardmdd/maxabs)*100.0) ;
0266
0267
0268
0269
0270
0271
0272
0273 }
0274 }
0275 return hasDifference ;
0276 }
0277
0278 int dbad_discrepancy4(float vareps, float var, float vard, float *dd, float *diff) {
0279 int hasDifference = 0 ;
0280 int almostZero = -15;
0281 int errMaxBits = 6;
0282 int trustableMantissa = 23;
0283 *dd = 0.0 ;
0284
0285 int expoTG ;
0286 frexpf(vard, &expoTG) ;
0287 float dv = vareps-var ;
0288 if (dv==0.0) {
0289 *dd = 0.0 ;
0290 if (vard==0.0 || expoTG<almostZero) {
0291 hasDifference = 0 ;
0292 *diff = 0.0 ;
0293 } else {
0294 hasDifference = 1;
0295 *diff = 100.0;
0296
0297
0298
0299
0300 }
0301 } else {
0302 *dd = dv/dbad_ddeps ;
0303 int expoDD ;
0304 frexpf(*dd, &expoDD) ;
0305 float hv = dv - dbad_ddeps*vard ;
0306 if (hv==0.0 || expoTG<almostZero || expoDD<almostZero) {
0307 hasDifference = 0 ;
0308 *diff = 0.0 ;
0309 } else {
0310 int expoDV, expoV1, expoV2, expoV, expoHV ;
0311 frexpf(dv, &expoDV) ;
0312 frexpf(var, &expoV1) ;
0313 frexpf(vareps, &expoV2) ;
0314 expoV = (var==0.0?expoV2:(vareps==0?expoV1:(expoV1>expoV2?expoV1:expoV2))) ;
0315 frexpf(hv, &expoHV) ;
0316 int discrepancySmallness = expoDV-expoHV ;
0317 int discrepancyExactness = trustableMantissa-expoV+expoDV ;
0318 hasDifference = (discrepancySmallness<errMaxBits && discrepancySmallness<discrepancyExactness) ;
0319
0320 float absvard = (vard>=0.0?vard:-vard) ;
0321 float absdd = (*dd>=0.0?*dd:-*dd) ;
0322 float maxabs = (absvard>absdd?absvard:absdd) ;
0323 float absvardmdd = vard-*dd ;
0324 if (absvardmdd<0.0) absvardmdd=-absvardmdd ;
0325 *diff = (absvardmdd/maxabs)*100.0 ;
0326
0327
0328
0329
0330
0331
0332
0333 }
0334 }
0335 return hasDifference ;
0336 }
0337
0338 void dbad_display_location(char *placename) {
0339 if (dbad_testThisProcess!=-2) {
0340 int i ;
0341 char* enclosproc = dbad_callStack->funcname ;
0342 int callStackDepth = dbad_callstackdepth() ;
0343 char indentWhite[20] = " " ;
0344 if (callStackDepth<10) indentWhite[2*callStackDepth]='\0';
0345 if (dbad_testThisProcess==-1) {
0346 printf("%s[%2i]AT:%s OF %s\n", indentWhite, callStackDepth, placename, enclosproc) ;
0347 } else {
0348 printf("[process %i] %s[%2i]AT:%s OF %s\n", dbad_testThisProcess, indentWhite, callStackDepth, placename, enclosproc) ;
0349 }
0350 }
0351 }
0352
0353 void dbad_adDebugTgt_testComplex16(char* varname, cdcmplx var, cdcmplx *vard, int conclude) {
0354 if (dbad_testThisProcess!=-2) {
0355 if (dbad_phase==1) {
0356 dbad_putOneVarName(varname) ;
0357 dbad_putOne8(var.dr) ;
0358 dbad_putOne8(var.di) ;
0359 } else if (dbad_phase==2) {
0360 cdcmplx ddvar, dd ;
0361 float diffR, diffI ;
0362 int hasDifferenceR, hasDifferenceI ;
0363 dbad_ddcheckvarname(varname) ;
0364 dbad_getOne8(&(ddvar.dr)) ;
0365 dbad_getOne8(&(ddvar.di)) ;
0366 hasDifferenceR = dbad_discrepancy8(ddvar.dr, var.dr, vard->dr, &(dd.dr), &diffR) ;
0367 hasDifferenceI = dbad_discrepancy8(ddvar.di, var.di, vard->di, &(dd.di), &diffI) ;
0368 if (dbad_trace) {
0369 printf("%s [v-eps:(%24.16e,%24.16e) v-loc:(%24.16e,%24.16e)] (%24.16e,%24.16e)(dd (%5.1f,%5.1f)%% DIFF? WITH ad)(%24.16e,%24.16e)\n",
0370 varname,ddvar.dr,ddvar.di,var.dr,var.di,dd.dr,dd.di,diffR,diffI,vard->dr,vard->di) ;
0371 } else if (hasDifferenceR||hasDifferenceI) {
0372 printf("%s (%24.16e,%24.16e)(dd (%5.1f,%5.1f)%% DIFF WITH ad)(%24.16e,%24.16e)\n",
0373 varname,dd,dd,diffR,diffI,vard->dr,vard->di) ;
0374 }
0375 if (conclude==-1) {
0376
0377 if (hasDifferenceR) {
0378 vard->dr = dd.dr ;
0379 printf("%s (.real) RESET:\n", varname) ;
0380 }
0381 if (hasDifferenceI) {
0382 vard->di = dd.di ;
0383 printf("%s (.imag) RESET:\n", varname) ;
0384 }
0385 }
0386 if (conclude==1) {
0387 cdcmplx varb ;
0388 varb.dr = dbad_nextRandom();
0389 varb.di = dbad_nextRandom();
0390 dbad_condensed_dd += dd.dr*varb.dr + dd.di*varb.di;
0391 dbad_condensed_tgt += vard->dr*varb.dr + vard->di*varb.di;
0392 }
0393 }
0394 }
0395 }
0396
0397 void dbad_adDebugTgt_testReal8(char* varname, double var, double *vard, int conclude) {
0398 if (dbad_testThisProcess!=-2) {
0399 if (dbad_phase==1) {
0400 dbad_putOneVarName(varname) ;
0401 dbad_putOne8(var) ;
0402 } else if (dbad_phase==2) {
0403 double ddvar, dd ;
0404 float diff ;
0405 dbad_ddcheckvarname(varname) ;
0406 dbad_getOne8(&ddvar) ;
0407 int hasDifference = dbad_discrepancy8(ddvar, var, *vard, &dd, &diff) ;
0408 if (dbad_trace) {
0409 printf("%s [v-eps:%24.16e v-loc:%24.16e] %24.16e(dd %5.1f%% DIFF? WITH ad)%24.16e\n",
0410 varname,ddvar,var,dd,diff,*vard) ;
0411 } else if (hasDifference) {
0412 printf("%s %24.16e(dd %5.1f%% DIFF WITH ad)%24.16e\n",
0413 varname,dd,diff,*vard) ;
0414 }
0415 if (conclude==-1 && hasDifference) {
0416
0417 *vard = dd ;
0418 printf("%s RESET:\n", varname) ;
0419 }
0420 if (conclude==1) {
0421 double varb = dbad_nextRandom() ;
0422 dbad_condensed_dd += dd*varb;
0423 dbad_condensed_tgt += *vard*varb;
0424 }
0425 }
0426 }
0427 }
0428
0429 void dbad_adDebugTgt_testReal4(char* varname, float var, float *vard, int conclude) {
0430 if (dbad_testThisProcess!=-2) {
0431 if (dbad_phase==1) {
0432 dbad_putOneVarName(varname) ;
0433 dbad_putOne4(var) ;
0434 } else if (dbad_phase==2) {
0435 float ddvar, dd ;
0436 float diff ;
0437 dbad_ddcheckvarname(varname) ;
0438 dbad_getOne4(&ddvar) ;
0439 int hasDifference = dbad_discrepancy4(ddvar, var, *vard, &dd, &diff) ;
0440 if (dbad_trace) {
0441 printf("%s [v-eps:%18.10e v-loc:%18.10e] %18.10e(dd %5.1f%% DIFF? WITH ad)%18.10e\n",
0442 varname,ddvar,var,dd,diff,*vard) ;
0443 } else if (hasDifference) {
0444 printf("%s %18.10e(dd %5.1f%% DIFF WITH ad)%18.10e\n",
0445 varname,dd,diff,*vard) ;
0446 }
0447 if (conclude==-1 && hasDifference) {
0448
0449 *vard = dd ;
0450 printf("%s RESET:\n", varname) ;
0451 }
0452 if (conclude==1) {
0453 double varb = dbad_nextRandom() ;
0454 dbad_condensed_dd += ((double)dd)*varb;
0455 dbad_condensed_tgt += ((double)*vard)*varb;
0456 }
0457 }
0458 }
0459 }
0460
0461 void dbad_adDebugTgt_testComplex16Array(char* varname, cdcmplx* var, cdcmplx* vard, int length, int conclude) {
0462 if (!var || !vard) return ;
0463 if (dbad_testThisProcess!=-2) {
0464 int i ;
0465 if (dbad_phase==1) {
0466 dbad_putOneVarName(varname) ;
0467 for (i=0 ; i<length ; ++i) {
0468 dbad_putOne8(var[i].dr) ;
0469 dbad_putOne8(var[i].di) ;
0470 }
0471 } else if (dbad_phase==2) {
0472 cdcmplx ddvar, dd, vardbuf[10], ddbuf[10], varepsbuf[10], varlocbuf[10] ;
0473 float diffR, diffI ;
0474 int hasDifferenceR, hasDifferenceI, printedheader = 0, indexbuf[10], ibuf = 0 ;
0475 dbad_ddcheckvarname(varname) ;
0476 for (i=0 ; i<length ; ++i) {
0477 dbad_getOne8(&ddvar.dr) ;
0478 dbad_getOne8(&ddvar.di) ;
0479 hasDifferenceR = dbad_discrepancy8(ddvar.dr, var[i].dr, vard[i].dr, &(dd.dr), &diffR) ;
0480 hasDifferenceI = dbad_discrepancy8(ddvar.di, var[i].di, vard[i].di, &(dd.di), &diffI) ;
0481 if (hasDifferenceR || hasDifferenceI || dbad_trace) {
0482 if (dbad_trace) {
0483 varepsbuf[ibuf] = ddvar ;
0484 varlocbuf[ibuf] = var[i] ;
0485 }
0486 vardbuf[ibuf] = vard[i] ;
0487 ddbuf[ibuf] = dd ;
0488 indexbuf[ibuf] = i ;
0489 ++ibuf ;
0490 }
0491 if (conclude==-1) {
0492
0493 if (hasDifferenceR) vard[i].dr = dd.dr ;
0494 if (hasDifferenceI) vard[i].di = dd.di ;
0495 }
0496 if (ibuf>=5 || (i==length-1 && ibuf>0)) {
0497 int j ;
0498 if (!printedheader) {
0499 if (conclude==-1)
0500 printf("%s RESET:\n", varname) ;
0501 else
0502 printf("%s DIFFS:\n", varname) ;
0503 printedheader = 1 ;
0504 }
0505 printf(" ") ;
0506 for (j=0 ; j<ibuf ; ++j)
0507 printf(" %4i->(%11.4e,%11.4e)", indexbuf[j], vardbuf[j].dr, vardbuf[j].di) ;
0508 printf("\n ") ;
0509 if (dbad_trace) {
0510 for (j=0 ; j<ibuf ; ++j)
0511 printf(" (eps)(%11.4e,%11.4e)", varepsbuf[j].dr, varepsbuf[j].di) ;
0512 printf("\n ") ;
0513 for (j=0 ; j<ibuf ; ++j)
0514 printf(" (loc)(%11.4e,%11.4e)", varlocbuf[j].dr, varlocbuf[j].di) ;
0515 printf("\n ") ;
0516 }
0517 for (j=0 ; j<ibuf ; ++j)
0518 printf(" (dd:)(%11.4e,%11.4e)", ddbuf[j].dr, ddbuf[j].di) ;
0519 printf("\n") ;
0520 ibuf = 0 ;
0521 }
0522 if (conclude==1) {
0523 cdcmplx varb ;
0524 varb.dr = dbad_nextRandom();
0525 varb.di = dbad_nextRandom();
0526 dbad_condensed_dd += dd.dr*varb.dr + dd.di*varb.di ;
0527 dbad_condensed_tgt += vard[i].dr*varb.dr + vard[i].di*varb.di ;
0528 }
0529 }
0530 }
0531 }
0532 }
0533
0534 void dbad_adDebugTgt_testReal8Array(char* varname, double* var, double* vard, int length, int conclude) {
0535 if (!var || !vard) return ;
0536 if (dbad_testThisProcess!=-2) {
0537 int i ;
0538 if (dbad_phase==1) {
0539 dbad_putOneVarName(varname) ;
0540 for (i=0 ; i<length ; ++i) {
0541 dbad_putOne8(var[i]) ;
0542 }
0543 } else if (dbad_phase==2) {
0544 double ddvar, dd, vardbuf[10], ddbuf[10], varepsbuf[10], varlocbuf[10] ;
0545 float diff ;
0546 int hasDifference, printedheader = 0, indexbuf[10], ibuf = 0 ;
0547 dbad_ddcheckvarname(varname) ;
0548 for (i=0 ; i<length ; ++i) {
0549 dbad_getOne8(&ddvar) ;
0550 hasDifference = dbad_discrepancy8(ddvar, var[i], vard[i], &dd, &diff) ;
0551 if (dbad_trace) {
0552 varepsbuf[ibuf] = ddvar ;
0553 varlocbuf[ibuf] = var[i] ;
0554 }
0555 if (hasDifference || dbad_trace) {
0556 vardbuf[ibuf] = vard[i] ;
0557 ddbuf[ibuf] = dd ;
0558 indexbuf[ibuf] = i ;
0559 ++ibuf ;
0560 }
0561 if (conclude==-1 && hasDifference) {
0562
0563 vard[i] = dd ;
0564 }
0565 if (ibuf>=10 || (i==length-1 && ibuf>0)) {
0566 int j ;
0567 if (!printedheader) {
0568 if (conclude==-1)
0569 printf("%s RESET:\n", varname) ;
0570 else
0571 printf("%s DIFFS:\n", varname) ;
0572 printedheader = 1 ;
0573 }
0574 printf(" ") ;
0575 for (j=0 ; j<ibuf ; ++j)
0576 printf(" %4i->%11.4e", indexbuf[j], vardbuf[j]) ;
0577 printf("\n ") ;
0578 if (dbad_trace) {
0579 for (j=0 ; j<ibuf ; ++j)
0580 printf(" (eps)%11.4e", varepsbuf[j]) ;
0581 printf("\n ") ;
0582 for (j=0 ; j<ibuf ; ++j)
0583 printf(" (loc)%11.4e", varlocbuf[j]) ;
0584 printf("\n ") ;
0585 }
0586 for (j=0 ; j<ibuf ; ++j)
0587 printf(" (dd:)%11.4e", ddbuf[j]) ;
0588 printf("\n") ;
0589 ibuf = 0 ;
0590 }
0591 if (conclude==1) {
0592 double varb = dbad_nextRandom() ;
0593 dbad_condensed_dd += dd*varb;
0594 dbad_condensed_tgt += vard[i]*varb;
0595 }
0596 }
0597 }
0598 }
0599 }
0600
0601 void dbad_adDebugTgt_testReal4Array(char* varname, float* var, float* vard, int length, int conclude) {
0602 if (!var || !vard) return ;
0603 if (dbad_testThisProcess!=-2) {
0604 int i ;
0605 if (dbad_phase==1) {
0606 dbad_putOneVarName(varname) ;
0607 for (i=0 ; i<length ; ++i) {
0608 dbad_putOne4(var[i]) ;
0609 }
0610 } else if (dbad_phase==2) {
0611 float ddvar, dd, vardbuf[10], ddbuf[10], varepsbuf[10], varlocbuf[10] ;
0612 float diff ;
0613 int hasDifference, printedheader = 0, indexbuf[10], ibuf = 0 ;
0614 dbad_ddcheckvarname(varname) ;
0615 for (i=0 ; i<length ; ++i) {
0616 dbad_getOne4(&ddvar) ;
0617 hasDifference = dbad_discrepancy4(ddvar, var[i], vard[i], &dd, &diff) ;
0618 if (dbad_trace) {
0619 varepsbuf[ibuf] = ddvar ;
0620 varlocbuf[ibuf] = var[i] ;
0621 }
0622 if (hasDifference || dbad_trace) {
0623 vardbuf[ibuf] = vard[i] ;
0624 ddbuf[ibuf] = dd ;
0625 indexbuf[ibuf] = i ;
0626 ++ibuf ;
0627 }
0628 if (conclude==-1 && hasDifference) {
0629
0630 vard[i] = dd ;
0631 }
0632 if (ibuf>=10 || (i==length-1 && ibuf>0)) {
0633 int j ;
0634 if (!printedheader) {
0635 if (conclude==-1)
0636 printf("%s RESET:\n", varname) ;
0637 else
0638 printf("%s DIFFS:\n", varname) ;
0639 printedheader = 1 ;
0640 }
0641 printf(" ") ;
0642 for (j=0 ; j<ibuf ; ++j)
0643 printf(" %4i->%11.4e", indexbuf[j], vardbuf[j]) ;
0644 printf("\n ") ;
0645 if (dbad_trace) {
0646 for (j=0 ; j<ibuf ; ++j)
0647 printf(" (eps)%11.4e", varepsbuf[j]) ;
0648 printf("\n ") ;
0649 for (j=0 ; j<ibuf ; ++j)
0650 printf(" (loc)%11.4e", varlocbuf[j]) ;
0651 printf("\n ") ;
0652 }
0653 for (j=0 ; j<ibuf ; ++j)
0654 printf(" (dd:)%11.4e", ddbuf[j]) ;
0655 printf("\n") ;
0656 ibuf = 0 ;
0657 }
0658 if (conclude==1) {
0659 double varb = dbad_nextRandom() ;
0660 dbad_condensed_dd += ((double)dd)*varb;
0661 dbad_condensed_tgt += ((double)vard[i])*varb;
0662 }
0663 }
0664 }
0665 }
0666 }
0667
0668
0669
0670 void adDebugTgt_init(double epsilon, double seed, int tested_process) {
0671
0672 dbad_mode = 1 ;
0673 dbad_ddeps = epsilon ;
0674 dbad_seed = seed ;
0675 dbad_topContext.funcname = "TESTED CODE\0" ;
0676 dbad_topContext.deltadepth = 0 ;
0677 dbad_topContext.code = 0 ;
0678 dbad_calltracedepth = 1 ;
0679 dbad_callStack = &dbad_topContext ;
0680 char* phase = getenv("DBAD_PHASE") ;
0681 if (phase==NULL) {
0682 printf("Please set DBAD_PHASE environment variable to 1 (perturbed), 2 (tangent), or 0 (no debug)\n") ;
0683 exit(0) ;
0684 } else if (strcmp(phase,"0")==0) {
0685 dbad_phase = 0 ;
0686 } else if (strcmp(phase,"1")==0) {
0687 dbad_phase = 1 ;
0688 } else if (strcmp(phase,"2")==0) {
0689 dbad_phase = 2 ;
0690 } else if (strcmp(phase,"-1")==0) {
0691 dbad_phase = 1 ;
0692 dbad_trace = 1 ;
0693 } else if (strcmp(phase,"-2")==0) {
0694 dbad_phase = 2 ;
0695 dbad_trace = 1 ;
0696 } else {
0697 printf("DBAD_PHASE environment variable must be set to 1 (perturbed), 2 (tangent), or 0 (no debug)\n") ;
0698 exit(0) ;
0699 }
0700 char* fifoFileName = "/tmp/DBAD_fifo" ;
0701 dbad_testThisProcess = -1 ;
0702 if (dbad_testThisProcess!=-2) {
0703 if (dbad_trace) {
0704 printf("INTERNAL TESTS, epsilon=%7.1e\n", epsilon) ;
0705 printf("===========================================================\n") ;
0706 }
0707 if (dbad_phase==1) {
0708 if (dbad_testThisProcess==-1) {
0709 printf("Starting TGT test, phase one, epsilon=%7.1e [seed=%7.1e]\n",
0710 epsilon, seed) ;
0711 } else {
0712 printf("[process %i] Starting TGT test, phase one, epsilon=%7.1e [seed=%7.1e]\n",
0713 dbad_testThisProcess, epsilon, seed) ;
0714 }
0715 printf("===========================================================\n") ;
0716 mkfifo(fifoFileName, S_IWUSR | S_IRUSR | S_IRGRP | S_IROTH | S_IRWXU | S_IRWXO) ;
0717 dbad_file = fopen(fifoFileName, "a") ;
0718 if (dbad_file==NULL) {
0719 char errbuf[20] ;
0720 strerror_r(errno, errbuf, 20) ;
0721 printf("FIFO ERROR %i: %s OR %s\n",errno,strerror(errno),errbuf) ;
0722 exit(0) ;
0723 }
0724 } else if (dbad_phase==2) {
0725 if (dbad_testThisProcess==-1) {
0726 printf("Starting TGT test, phase two, epsilon=%7.1e [seed=%7.1e]\n",
0727 epsilon, seed) ;
0728 } else {
0729 printf("[process %i] Starting TGT test, phase two, epsilon=%7.1e [seed=%7.1e]\n",
0730 dbad_testThisProcess, epsilon, seed) ;
0731 }
0732 printf("===========================================================\n") ;
0733 dbad_file = fopen(fifoFileName, "r") ;
0734 }
0735 dbad_resetCondensors() ;
0736 }
0737 }
0738
0739 void adDebugTgt_call(char* unitname, int deltadepth, int forcetraced) {
0740 if (dbad_trace) {
0741 printf("call %s deltadepth:%i forcetraced:%i\n", unitname, deltadepth, forcetraced) ;
0742 }
0743 if (dbad_phase!=0) {
0744 dbad_pushCallFrame(unitname, deltadepth, forcetraced) ;
0745 }
0746 }
0747
0748 void adDebugTgt_exit() {
0749 if (dbad_trace) {
0750 printf("exit\n") ;
0751 }
0752 if (dbad_phase!=0) {
0753 dbad_popCallFrame() ;
0754 }
0755 dbad_resetCondensors() ;
0756 }
0757
0758 int adDebugTgt_here(char* placename, int forcetraced) {
0759 if (dbad_testThisProcess!=-2) {
0760 if (dbad_trace) {
0761 printf("here?? %s forcetraced:%i\n", placename, forcetraced) ;
0762 printf(" will return %i\n", (dbad_phase==0?0:dbad_debughere(forcetraced))) ;
0763 }
0764 if (dbad_phase==0) return 0 ;
0765 return dbad_debughere(forcetraced) ;
0766 } else {
0767 return 0 ;
0768 }
0769 }
0770
0771 void adDebugTgt_initComplex16(char* varname, cdcmplx *indep, cdcmplx *indepd) {
0772 indepd->dr = dbad_nextRandom() ;
0773 indepd->di = dbad_nextRandom() ;
0774
0775 if (dbad_phase==1) {
0776 indep->dr = (indep->dr)+dbad_ddeps*(indepd->dr) ;
0777 indep->di = (indep->di)+dbad_ddeps*(indepd->di) ;
0778 }
0779 if (dbad_trace)
0780 printf("initComplex16 of %s: (%24.16e,%24.16e) //(%24.16e,%24.16e)\n", varname, indep->dr, indep->di, indepd->dr, indepd->di) ;
0781 }
0782
0783 void adDebugTgt_initReal8(char* varname, double *indep, double *indepd) {
0784 *indepd = dbad_nextRandom() ;
0785
0786 if (dbad_phase==1)
0787 *indep = (*indep)+dbad_ddeps*(*indepd) ;
0788 if (dbad_trace)
0789 printf("initReal8 of %s: %24.16e //%24.16e\n", varname, *indep, *indepd) ;
0790 }
0791
0792 void adDebugTgt_initReal4(char* varname, float *indep, float *indepd) {
0793 *indepd = (float)dbad_nextRandom() ;
0794
0795 if (dbad_phase==1)
0796 *indep = (*indep)+dbad_ddeps*(*indepd) ;
0797 if (dbad_trace)
0798 printf("initReal4 of %s: %24.16e //%24.16e\n", varname, (double)*indep, (double)*indepd) ;
0799 }
0800
0801 void adDebugTgt_initComplex16Array(char* varname, cdcmplx *indep, cdcmplx *indepd, int length) {
0802 if (!indep || !indepd) return ;
0803 int i ;
0804 for (i=0 ; i<length ; ++i) {
0805 indepd[i].dr = dbad_nextRandom() ;
0806 indepd[i].di = dbad_nextRandom() ;
0807
0808
0809
0810 }
0811 if (dbad_phase==1) {
0812 for (i=0 ; i<length ; ++i) {
0813 indep[i].dr += dbad_ddeps*indepd[i].dr ;
0814 indep[i].di += dbad_ddeps*indepd[i].di ;
0815 }
0816 }
0817 if (dbad_trace) {
0818 printf("initComplex16Array of %s, length=%i:\n", varname, length) ;
0819 for (i=0 ; i<length ; ++i)
0820 printf(" %i:(%24.16e,%24.16e) //(%24.16e,%24.16e)",i,indep[i].dr,indep[i].di,indepd[i].dr,indepd[i].di) ;
0821 printf("\n") ;
0822 }
0823 }
0824
0825 void adDebugTgt_initReal8Array(char* varname, double *indep, double *indepd, int length) {
0826 if (!indep || !indepd) return ;
0827 int i ;
0828 for (i=0 ; i<length ; ++i) {
0829 indepd[i] = dbad_nextRandom() ;
0830
0831
0832
0833 }
0834 if (dbad_phase==1) {
0835 for (i=0 ; i<length ; ++i) {
0836 indep[i] = indep[i]+dbad_ddeps*indepd[i] ;
0837 }
0838 }
0839 if (dbad_trace) {
0840 printf("initReal8Array of %s, length=%i:\n", varname, length) ;
0841 for (i=0 ; i<length ; ++i)
0842 printf(" %i:%24.16e //%24.16e",i,indep[i],indepd[i]) ;
0843 printf("\n") ;
0844 }
0845 }
0846
0847 void adDebugTgt_initReal4Array(char* varname, float *indep, float *indepd, int length) {
0848 if (!indep || !indepd) return ;
0849 int i ;
0850 for (i=0 ; i<length ; ++i) {
0851 indepd[i] = (float)dbad_nextRandom() ;
0852
0853 }
0854 if (dbad_phase==1) {
0855 for (i=0 ; i<length ; ++i) {
0856 indep[i] = indep[i]+dbad_ddeps*indepd[i] ;
0857 }
0858 }
0859 if (dbad_trace) {
0860 printf("initReal4Array of %s, length=%i:\n", varname, length) ;
0861 for (i=0 ; i<length ; ++i)
0862 printf(" %i:%24.16e //%24.16e",i,(double)indep[i],(double)indepd[i]) ;
0863 printf("\n") ;
0864 }
0865 }
0866
0867 void adDebugTgt_passiveComplex16(char *varname, cdcmplx var) {
0868 if (dbad_testThisProcess!=-2) {
0869 if (dbad_phase==1) {
0870 dbad_putOneVarName(varname) ;
0871 dbad_putOne8(var.dr) ;
0872 dbad_putOne8(var.di) ;
0873 } else if (dbad_phase==2) {
0874 cdcmplx ddvar ;
0875 dbad_ddcheckvarname(varname) ;
0876 dbad_getOne8(&(ddvar.dr)) ;
0877 dbad_getOne8(&(ddvar.di)) ;
0878 if (dbad_trace) {
0879 printf("passiveComplex16 %s v-eps:(%24.16e,%24.16e) v-loc:(%24.16e,%24.16e) are %s\n",
0880 varname,ddvar.dr,ddvar.di,var.dr,var.di,(ddvar.dr==var.dr && ddvar.di==var.di?"equal":"different")) ;
0881 } else if (ddvar.dr!=var.dr || ddvar.di!=var.di) {
0882 printf("passiveComplex16 %s appears to be varied (v-eps:(%24.16e,%24.16e) v-loc:(%24.16e,%24.16e)). Hope it is really not useful!\n",
0883 varname,ddvar.dr,ddvar.di,var.dr,var.di) ;
0884 }
0885 }
0886 }
0887 }
0888
0889 void adDebugTgt_passiveReal8(char *varname, double var) {
0890 if (dbad_testThisProcess!=-2) {
0891 if (dbad_phase==1) {
0892 dbad_putOneVarName(varname) ;
0893 dbad_putOne8(var) ;
0894 } else if (dbad_phase==2) {
0895 double ddvar ;
0896 dbad_ddcheckvarname(varname) ;
0897 dbad_getOne8(&ddvar) ;
0898 if (dbad_trace) {
0899 printf("passiveReal8 %s v-eps:%24.16e v-loc:%24.16e are %s\n",
0900 varname,ddvar,var,(ddvar==var?"equal":"different")) ;
0901 } else if (ddvar!=var) {
0902 printf("passiveReal8 %s appears to be varied (v-eps:%24.16e v-loc:%24.16e). Hope it is really not useful!\n",
0903 varname,ddvar,var) ;
0904 }
0905 }
0906 }
0907 }
0908
0909 void adDebugTgt_passiveReal4(char *varname, float var) {
0910 if (dbad_testThisProcess!=-2) {
0911 if (dbad_phase==1) {
0912 dbad_putOneVarName(varname) ;
0913 dbad_putOne4(var) ;
0914 } else if (dbad_phase==2) {
0915 float ddvar ;
0916 dbad_ddcheckvarname(varname) ;
0917 dbad_getOne4(&ddvar) ;
0918 if (dbad_trace) {
0919 printf("passiveReal4 %s v-eps:%18.10 v-loc:%18.10 are %s\n",
0920 varname,ddvar,var,(ddvar==var?"equal":"different")) ;
0921 } else if (ddvar!=var) {
0922 printf("passiveReal4 %s appears to be varied (v-eps:%18.10 v-loc:%18.10). Hope it is really not useful!\n",
0923 varname,ddvar,var) ;
0924 }
0925 }
0926 }
0927 }
0928
0929 void adDebugTgt_passiveComplex16Array(char *varname, cdcmplx *var, int length) {
0930 if (!var) return;
0931 if (dbad_testThisProcess!=-2) {
0932 int i ;
0933 double varsum = 0.0 ;
0934 for (i=0 ; i<length ; ++i) {
0935 varsum += var[i].dr + var[i].di ;
0936 }
0937 adDebugTgt_passiveReal8(varname, varsum) ;
0938 }
0939 }
0940
0941 void adDebugTgt_passiveReal8Array(char *varname, double *var, int length) {
0942 if (!var) return;
0943 if (dbad_testThisProcess!=-2) {
0944 int i ;
0945 double varsum = 0.0 ;
0946 for (i=0 ; i<length ; ++i) {
0947 varsum += var[i] ;
0948 }
0949 adDebugTgt_passiveReal8(varname, varsum) ;
0950 }
0951 }
0952
0953 void adDebugTgt_passiveReal4Array(char *varname, float *var, int length) {
0954 if (!var) return;
0955 if (dbad_testThisProcess!=-2) {
0956 int i ;
0957 float varsum = 0.0 ;
0958 for (i=0 ; i<length ; ++i) {
0959 varsum += var[i] ;
0960 }
0961 adDebugTgt_passiveReal4(varname, varsum) ;
0962 }
0963 }
0964
0965 void adDebugTgt_testComplex16(char *varname, cdcmplx var, cdcmplx *vard) {
0966 dbad_adDebugTgt_testComplex16(varname, var, vard,
0967 #ifdef ADDEBUG_NUDGE
0968 -1
0969 #else
0970 0
0971 #endif
0972 ) ;
0973 }
0974
0975 void adDebugTgt_testReal8(char *varname, double var, double *vard) {
0976 dbad_adDebugTgt_testReal8(varname, var, vard,
0977 #ifdef ADDEBUG_NUDGE
0978 -1
0979 #else
0980 0
0981 #endif
0982 ) ;
0983 }
0984
0985 void adDebugTgt_testReal4(char *varname, float var, float *vard) {
0986 dbad_adDebugTgt_testReal4(varname, var, vard,
0987 #ifdef ADDEBUG_NUDGE
0988 -1
0989 #else
0990 0
0991 #endif
0992 ) ;
0993 }
0994
0995 void adDebugTgt_testComplex16Array(char *varname, cdcmplx* var, cdcmplx* vard, int length) {
0996 dbad_adDebugTgt_testComplex16Array(varname, var, vard, length,
0997 #ifdef ADDEBUG_NUDGE
0998 -1
0999 #else
1000 0
1001 #endif
1002 ) ;
1003 }
1004
1005 void adDebugTgt_testReal8Array(char *varname, double* var, double* vard, int length) {
1006 dbad_adDebugTgt_testReal8Array(varname, var, vard, length,
1007 #ifdef ADDEBUG_NUDGE
1008 -1
1009 #else
1010 0
1011 #endif
1012 ) ;
1013 }
1014
1015 void adDebugTgt_testReal4Array(char *varname, float* var, float* vard, int length) {
1016 dbad_adDebugTgt_testReal4Array(varname, var, vard, length,
1017 #ifdef ADDEBUG_NUDGE
1018 -1
1019 #else
1020 0
1021 #endif
1022 ) ;
1023 }
1024
1025 void adDebugTgt_concludeComplex16(char* varname, cdcmplx var, cdcmplx *vard) {
1026 dbad_adDebugTgt_testComplex16(varname, var, vard, 1) ;
1027 }
1028
1029 void adDebugTgt_concludeReal8(char* varname, double var, double *vard) {
1030 dbad_adDebugTgt_testReal8(varname, var, vard, 1) ;
1031 }
1032
1033 void adDebugTgt_concludeReal4(char* varname, float var, float *vard) {
1034 dbad_adDebugTgt_testReal4(varname, var, vard, 1) ;
1035 }
1036
1037 void adDebugTgt_concludeComplex16Array(char* varname, cdcmplx *var, cdcmplx *vard, int length) {
1038 dbad_adDebugTgt_testComplex16Array(varname, var, vard, length, 1) ;
1039 }
1040
1041 void adDebugTgt_concludeReal8Array(char* varname, double *var, double *vard, int length) {
1042
1043 dbad_adDebugTgt_testReal8Array(varname, var, vard, length, 1) ;
1044 }
1045
1046 void adDebugTgt_concludeReal4Array(char* varname, float *var, float *vard, int length) {
1047 dbad_adDebugTgt_testReal4Array(varname, var, vard, length, 1) ;
1048 }
1049
1050 void adDebugTgt_conclude() {
1051 if (dbad_testThisProcess!=-2) {
1052 printf("===========================================================\n") ;
1053 if (dbad_trace) {
1054 if (dbad_testThisProcess==-1) {
1055 printf("Condensed results: %24.16e //%24.16e",dbad_condensed_tgt,dbad_condensed_dd) ;
1056 } else {
1057 printf("[process %i] Condensed results: %24.16e //%24.16e",dbad_testThisProcess,dbad_condensed_tgt,dbad_condensed_dd) ;
1058 }
1059 }
1060 if (dbad_phase==2) {
1061 double abstgt, absdd, maxabs, abserror, diff ;
1062 abstgt = (dbad_condensed_tgt>=0.0?dbad_condensed_tgt:-dbad_condensed_tgt) ;
1063 absdd = (dbad_condensed_dd>=0.0?dbad_condensed_dd:-dbad_condensed_dd) ;
1064 maxabs = (abstgt>absdd?abstgt:absdd) ;
1065 abserror = dbad_condensed_tgt-dbad_condensed_dd ;
1066 if (abserror<0.0) abserror=-abserror ;
1067 diff = (abserror*100.0)/ maxabs ;
1068 if (dbad_testThisProcess==-1) {
1069 printf("Condensed tangent: %24.16e (ad)%5.1f%% DIFF WITH (dd)%24.16e [seed:%7.1e]\n",
1070 dbad_condensed_tgt,diff,dbad_condensed_dd,dbad_seed) ;
1071 } else {
1072 printf("[process %i] Condensed tangent: %24.16e (ad)%5.1f%% DIFF WITH (dd)%24.16e [seed:%7.1e]\n",
1073 dbad_testThisProcess,dbad_condensed_tgt,diff,dbad_condensed_dd,dbad_seed) ;
1074 }
1075 }
1076 }
1077 }
1078
1079 void adDebugTgt_display(char *placename) {
1080 if (dbad_testThisProcess!=-2) {
1081 if (dbad_trace) {
1082 if (dbad_testThisProcess==-1) {
1083 printf("display %s\n", placename) ;
1084 } else {
1085 printf("[process %i] display %s\n", dbad_testThisProcess, placename) ;
1086 }
1087 }
1088 if (dbad_phase==2) {
1089 dbad_display_location(placename) ;
1090 }
1091 }
1092 }
1093
1094
1095
1096 void adDebugBwd_init(double errmax, double seed) {
1097 dbad_mode = -1 ;
1098 dbad_phase = 1 ;
1099 dbad_errormax = errmax ;
1100 dbad_seed = seed ;
1101 dbad_topContext.funcname = "TESTED CODE\0" ;
1102 dbad_topContext.deltadepth = 0 ;
1103 dbad_topContext.code = 0 ;
1104 dbad_calltracedepth = 1 ;
1105 dbad_callStack = &dbad_topContext ;
1106 char* phase = getenv("DBAD_PHASE") ;
1107 if (phase==NULL) {
1108 printf("Please set DBAD_PHASE environment variable to 0 (no debug), 1 (sendToTgt), or -1 (plusTraces)\n") ;
1109 dbad_phase = 1 ;
1110 } else if (strcmp(phase,"0")==0) {
1111 dbad_phase = 1 ;
1112 dbad_nocommunication = 1 ;
1113 } else if (strcmp(phase,"1")==0) {
1114 dbad_phase = 1 ;
1115 } else if (strcmp(phase,"-1")==0) {
1116 dbad_phase = 1 ;
1117 dbad_trace = 1 ;
1118 } else {
1119 printf("DBAD_PHASE environment variable must be set to 0 (no debug), 1 (sendToTgt), or -1 (plusTraces)\n") ;
1120 exit(0) ;
1121 }
1122 printf("Starting ADJ test, phase one (bwd), errmax=%4.1f% [seed=%7.1e]\n", errmax, seed) ;
1123 printf("===========================================================\n") ;
1124 if (dbad_nocommunication) {
1125 dbad_file = NULL ;
1126 printf("FIFO COMMUNICATION TURNED OFF !\n") ;
1127 } else {
1128 mkfifo("/tmp/DBAD_fifo", S_IWUSR | S_IRUSR | S_IRGRP | S_IROTH | S_IRWXU | S_IRWXO) ;
1129 dbad_file = fopen("/tmp/DBAD_fifo", "a") ;
1130 if (dbad_file==NULL) {
1131 char errbuf[20] ;
1132 strerror_r(errno, errbuf, 20) ;
1133 printf("FIFO ERROR %i: %s OR %s\n",errno,strerror(errno),errbuf) ;
1134 exit(0) ;
1135 }
1136 }
1137 dbad_resetCondensors() ;
1138 }
1139
1140 void adDebugBwd_call(char *funcname, int deltadepth) {
1141 dbad_pushCallFrame(funcname, deltadepth, 0) ;
1142 }
1143
1144 void adDebugBwd_exit() {
1145 dbad_resetCondensors() ;
1146 if (dbad_debugabove()) {
1147 if (dbad_nocommunication) {
1148 printf("adDebug would send (%i %s)\n", (dbad_debughere(0)?2:-2), dbad_callStack->funcname) ;
1149 } else {
1150 fprintf(dbad_file, "%i\n", (dbad_debughere(0)?2:-2)) ;
1151 fprintf(dbad_file, "%s\n", dbad_callStack->funcname) ;
1152 }
1153 }
1154 dbad_popCallFrame() ;
1155 }
1156
1157 int adDebugBwd_here(char* placename) {
1158 dbad_resetCondensors() ;
1159 return adDebugTgt_here(placename, 0) ;
1160 }
1161
1162
1163
1164 void adDebugFwd_init(double errmax, double seed) {
1165 dbad_mode = -1 ;
1166 dbad_phase = 2 ;
1167 dbad_errormax = errmax ;
1168 dbad_seed = seed ;
1169 dbad_topContext.funcname = "TESTED CODE\0" ;
1170 dbad_topContext.deltadepth = 0 ;
1171 dbad_topContext.code = 0 ;
1172 dbad_calltracedepth = 1 ;
1173 dbad_callStack = &dbad_topContext ;
1174 char* phase = getenv("DBAD_PHASE") ;
1175 if (phase==NULL) {
1176 printf("Please set DBAD_PHASE environment variable to 0 (no debug), 2 (readFromAdj), or -2 (plusTraces)\n") ;
1177 dbad_phase = 2 ;
1178 } else if (strcmp(phase,"0")==0) {
1179 dbad_phase = 2 ;
1180 dbad_nocommunication = 1 ;
1181 } else if (strcmp(phase,"2")==0) {
1182 dbad_phase = 2 ;
1183 } else if (strcmp(phase,"-2")==0) {
1184 dbad_phase = 2 ;
1185 dbad_trace = 1 ;
1186 } else {
1187 printf("DBAD_PHASE environment variable must be set to 0 (no debug), 2 (readFromAdj), or -2 (plusTraces)\n") ;
1188 exit(0) ;
1189 }
1190 dbad_nberrors = 0 ;
1191 printf("Starting ADJ test, phase two (fwd), errmax=%4.1f% [seed=%7.1e]\n", errmax, seed) ;
1192 printf("===========================================================\n") ;
1193 if (dbad_nocommunication) {
1194 dbad_file = NULL ;
1195 printf("FIFO COMMUNICATION TURNED OFF !\n") ;
1196 } else {
1197 dbad_file = fopen("/tmp/DBAD_fifo", "r") ;
1198 dbad_resetCondensors() ;
1199
1200
1201
1202
1203
1204
1205
1206 int ret=0 ;
1207 int label ;
1208 char placename[40] ;
1209 double value ;
1210 while (1) {
1211 ret = fscanf(dbad_file, "%i\n", &label) ;
1212 if (ret!=1) break ;
1213 ret = fscanf(dbad_file, "%s\n", placename) ;
1214 if (label==1) {
1215 ret = fscanf(dbad_file, "%lf\n", &value) ;
1216 dbad_pushReal8(value) ;
1217 }
1218 pushCharacterArray(placename, 40) ;
1219 dbad_pushinteger4(label) ;
1220 }
1221 }
1222 }
1223
1224 void adDebugFwd_call(char *funcname) {
1225 int label ;
1226 char funcnamefrom[40] ;
1227 char funcnamehere[40] ;
1228
1229
1230 if (dbad_debughere(0) && !(dbad_nocommunication && dbad_phase==2)) {
1231 dbad_popinteger4(&label) ;
1232 if (label!=2 && label!=-2) {
1233 printf("Control mismatch, expecting a trace (-2or2) from %s bwd call exit, got %i\n",funcname,label) ;
1234 exit(0) ;
1235 }
1236 popCharacterArray(funcnamefrom, 40) ;
1237 sprintf(funcnamehere,"%s",funcname) ;
1238 if (strcmp(funcnamefrom,funcnamehere)!=0) {
1239 printf("Control mismatch, expecting a call to %s, got %s\n",funcnamehere,funcnamefrom) ;
1240 exit(0) ;
1241 }
1242 dbad_pushCallFrame(funcname, 0, 0) ;
1243 if (label==2) {
1244 dbad_callStack->deltadepth += (dbad_calltracedepth-1) ;
1245 dbad_calltracedepth = 1 ;
1246 } else {
1247 dbad_callStack->deltadepth += dbad_calltracedepth ;
1248 dbad_calltracedepth = 0 ;
1249 }
1250 } else {
1251 dbad_pushCallFrame(funcname, 0, 0) ;
1252 }
1253 }
1254
1255 void adDebugFwd_exit() {
1256 dbad_popCallFrame() ;
1257 }
1258
1259 int adDebugFwd_here(char* placename) {
1260
1261
1262
1263 if (dbad_nocommunication && dbad_phase==2) {
1264 if (strcmp(placename,"end")==0 || strcmp(placename,"start")==0)
1265 return 1 ;
1266 else
1267 return 0 ;
1268 } else {
1269 if (dbad_debughere(0)) {
1270 int label ;
1271 char placenamefrom[40] ;
1272 char placenamehere[40] ;
1273 dbad_resetCondensors() ;
1274 dbad_popinteger4(&label) ;
1275 if (label!=1 && label!=-1 && label!=0) {
1276 printf("Control mismatch, expecting a trace (-1or0or1) from place %s, got %i\n",placename,label) ;
1277 exit(0) ;
1278 }
1279 popCharacterArray(placenamefrom, 40) ;
1280 sprintf(placenamehere,"%s",placename) ;
1281 if (strcmp(placenamefrom,placenamehere)!=0) {
1282 printf("Control mismatch, expecting place %s, got %s\n",placenamehere,placenamefrom) ;
1283 exit(0) ;
1284 }
1285 if (label==1) {
1286 dbad_popReal8(&dbad_nextrefsum) ;
1287 }
1288 return label!=-1 ;
1289 } else {
1290 return 0 ;
1291 }
1292 }
1293 }
1294
1295
1296
1297 void adDebugAdj_rwComplex16(cdcmplx *vard) {
1298 double varbR = dbad_nextRandom() ;
1299 double varbI = dbad_nextRandom() ;
1300 dbad_condensed_adj += varbR*(vard->dr) + varbI*(vard->di) ;
1301 vard->dr = varbR ;
1302 vard->di = varbI ;
1303 }
1304
1305 void adDebugAdj_rwReal8(double *vard) {
1306 double varb = dbad_nextRandom() ;
1307 dbad_condensed_adj += varb*(*vard) ;
1308 *vard = varb ;
1309 }
1310
1311 void adDebugAdj_rwReal4(float *vard) {
1312 double varb = dbad_nextRandom() ;
1313 dbad_condensed_adj += varb*(*vard) ;
1314 *vard = (float)varb ;
1315 }
1316
1317 void adDebugAdj_rComplex16(cdcmplx *vard) {
1318 double varbR = dbad_nextRandom() ;
1319 double varbI = dbad_nextRandom() ;
1320 dbad_condensed_adj += varbR*(vard->dr) + varbI*(vard->di) ;
1321 }
1322
1323
1324
1325
1326 void adDebugAdj_rReal8(double *vard) {
1327 double varb = dbad_nextRandom() ;
1328 dbad_condensed_adj += varb*(*vard) ;
1329 }
1330
1331
1332
1333
1334 void adDebugAdj_rReal4(float *vard) {
1335 double varb = dbad_nextRandom() ;
1336 dbad_condensed_adj += varb*(*vard) ;
1337 }
1338
1339 void adDebugAdj_wComplex16(cdcmplx *vard) {
1340 vard->dr = dbad_nextRandom() ;
1341 vard->di = dbad_nextRandom() ;
1342 }
1343
1344 void adDebugAdj_wReal8(double *vard) {
1345 *vard = dbad_nextRandom() ;
1346 }
1347
1348 void adDebugAdj_wReal4(float *vard) {
1349 *vard = (float)dbad_nextRandom() ;
1350 }
1351
1352 void adDebugAdj_rwComplex16Array(cdcmplx *vard, int length) {
1353 int i ;
1354 if (vard)
1355 for (i=0 ; i<length ; ++i)
1356 adDebugAdj_rwComplex16(&(vard[i])) ;
1357 }
1358
1359 void adDebugAdj_rwReal8Array(double *vard, int length) {
1360 int i ;
1361 if (vard)
1362 for (i=0 ; i<length ; ++i)
1363 adDebugAdj_rwReal8(&(vard[i])) ;
1364 }
1365
1366 void adDebugAdj_rwReal4Array(float *vard, int length) {
1367 int i ;
1368 if (vard)
1369 for (i=0 ; i<length ; ++i)
1370 adDebugAdj_rwReal4(&(vard[i])) ;
1371 }
1372
1373 void adDebugAdj_rComplex16Array(cdcmplx *vard, int length) {
1374 int i ;
1375 if (vard)
1376 for (i=0 ; i<length ; ++i)
1377 adDebugAdj_rComplex16(&(vard[i])) ;
1378 }
1379
1380 void adDebugAdj_rReal8Array(double *vard, int length) {
1381 int i ;
1382 if (vard)
1383 for (i=0 ; i<length ; ++i)
1384 adDebugAdj_rReal8(&(vard[i])) ;
1385 }
1386
1387 void adDebugAdj_rReal4Array(float *vard, int length) {
1388 int i ;
1389 if (vard)
1390 for (i=0 ; i<length ; ++i)
1391 adDebugAdj_rReal4(&(vard[i])) ;
1392 }
1393
1394 void adDebugAdj_wComplex16Array(cdcmplx *vard, int length) {
1395 int i ;
1396 if (vard)
1397 for (i=0 ; i<length ; ++i)
1398 adDebugAdj_wComplex16(&(vard[i])) ;
1399 }
1400
1401 void adDebugAdj_wReal8Array(double *vard, int length) {
1402 int i ;
1403 if (vard)
1404 for (i=0 ; i<length ; ++i)
1405 adDebugAdj_wReal8(&(vard[i])) ;
1406 }
1407
1408 void adDebugAdj_wReal4Array(float *vard, int length) {
1409 int i ;
1410 if (vard)
1411 for (i=0 ; i<length ; ++i)
1412 adDebugAdj_wReal4(&(vard[i])) ;
1413 }
1414
1415 void adDebugAdj_rwDisplay(char *placename, int indent) {
1416 adDebugAdj_rDisplay(placename, indent) ;
1417 if (dbad_phase==2)
1418 dbad_refsum = dbad_nextrefsum ;
1419 }
1420
1421 void adDebugAdj_rDisplay(char *placename, int indent) {
1422 if (dbad_phase==1) {
1423 if (dbad_nocommunication) {
1424 printf("adDebug would send (1 %s %24.16e)\n", placename, dbad_condensed_adj) ;
1425 } else {
1426 fprintf(dbad_file, "1\n") ;
1427 fprintf(dbad_file, "%s\n", placename) ;
1428 fprintf(dbad_file, "%24.16e\n", dbad_condensed_adj) ;
1429 }
1430 } else if (dbad_phase==2) {
1431
1432
1433 if (dbad_nocommunication) {
1434 printf("Condensed tangent result is %24.16e\n", dbad_condensed_adj) ;
1435 } else {
1436 double absref = (dbad_refsum>=0.0?dbad_refsum:-dbad_refsum) ;
1437 double absadj = (dbad_condensed_adj>=0.0?dbad_condensed_adj:-dbad_condensed_adj) ;
1438 double absdiff = dbad_refsum - dbad_condensed_adj ;
1439 if (absdiff<0.0) absdiff = -absdiff ;
1440 double reldiff = (absdiff*200.0)/(absref+absadj) ;
1441 if (reldiff>dbad_errormax) {
1442 printf(" %5.1f%% DIFFERENCE!! tgt:%24.16e adj:%24.16e\n",
1443 reldiff, dbad_condensed_adj, dbad_refsum) ;
1444 ++dbad_nberrors ;
1445 } else if (strcmp(placename,"end")==0 && dbad_nberrors==0) {
1446
1447 printf(" difference is just %7.3f% between tgt:%24.16e and adj:%24.16e\n",
1448 reldiff, dbad_condensed_adj, dbad_refsum) ;
1449 }
1450 if (indent==0) dbad_display_location(placename) ;
1451 }
1452 }
1453 dbad_resetCondensors() ;
1454 }
1455
1456 void adDebugAdj_wDisplay(char *placename, int indent) {
1457 if (dbad_phase==1) {
1458 if (dbad_nocommunication) {
1459 printf("adDebug would send (0 %s)\n", placename) ;
1460 } else {
1461 fprintf(dbad_file, "0\n") ;
1462 fprintf(dbad_file, "%s\n", placename) ;
1463 }
1464 } else if (dbad_phase==2) {
1465 if (indent==0) dbad_display_location(placename) ;
1466 dbad_refsum = dbad_nextrefsum ;
1467 }
1468 dbad_resetCondensors() ;
1469 }
1470
1471 void adDebugAdj_skip(char *placename) {
1472 if (dbad_phase==1 && dbad_debughere(0)) {
1473 if (dbad_nocommunication) {
1474 printf("adDebug would send (-1 %s)\n", placename) ;
1475 } else {
1476 fprintf(dbad_file, "-1\n") ;
1477 fprintf(dbad_file, "%s\n", placename) ;
1478 }
1479 }
1480 }
1481
1482 void adDebugAdj_conclude() {
1483 if (dbad_phase==2) {
1484 if (!dbad_nocommunication) {
1485
1486
1487 printf("End of ADJ test, %i error(s) found.\n", dbad_nberrors) ;
1488 printf("===========================================================\n") ;
1489 }
1490 }
1491 }
1492
1493
1494
1495
1496
1497
1498
1499 void addebugtgt_init_(double *epsilon, double *seed, int *tested_process) {
1500 adDebugTgt_init(*epsilon, *seed, *tested_process) ;
1501 }
1502
1503 void addebugtgt_call_(char* unitname, int *deltadepth, int *forcetraced) {
1504 adDebugTgt_call(unitname, *deltadepth, *forcetraced) ;
1505 }
1506
1507 void addebugtgt_exit_() {
1508 adDebugTgt_exit() ;
1509 }
1510
1511 int addebugtgt_here_(char* placename, int *forcetraced) {
1512 return adDebugTgt_here(placename, *forcetraced) ;
1513 }
1514
1515 void addebugtgt_initcomplex16_(char* varname, cdcmplx *indep, cdcmplx *indepd) {
1516 adDebugTgt_initComplex16(varname, indep, indepd) ;
1517 }
1518
1519 void addebugtgt_initreal8_(char* varname, double *indep, double *indepd) {
1520 adDebugTgt_initReal8(varname, indep, indepd) ;
1521 }
1522
1523 void addebugtgt_initreal4_(char* varname, float *indep, float *indepd) {
1524 adDebugTgt_initReal4(varname, indep, indepd) ;
1525 }
1526
1527 void addebugtgt_initcomplex16array_(char* varname, cdcmplx *indep, cdcmplx *indepd, int *length) {
1528 adDebugTgt_initComplex16Array(varname, indep, indepd, *length) ;
1529 }
1530
1531 void addebugtgt_initreal8array_(char* varname, double *indep, double *indepd, int *length) {
1532 adDebugTgt_initReal8Array(varname, indep, indepd, *length) ;
1533 }
1534
1535 void addebugtgt_initreal4array_(char* varname, float *indep, float *indepd, int *length) {
1536 adDebugTgt_initReal4Array(varname, indep, indepd, *length) ;
1537 }
1538
1539 void addebugtgt_passivecomplex16_(char *varname, cdcmplx *var) {
1540 adDebugTgt_passiveComplex16(varname, *var) ;
1541 }
1542
1543 void addebugtgt_passivereal8_(char *varname, double *var) {
1544 adDebugTgt_passiveReal8(varname, *var) ;
1545 }
1546
1547 void addebugtgt_passivereal4_(char *varname, float *var) {
1548 adDebugTgt_passiveReal4(varname, *var) ;
1549 }
1550
1551 void addebugtgt_passivecomplex16array_(char *varname, cdcmplx *var, int *length) {
1552 adDebugTgt_passiveComplex16Array(varname, var, *length) ;
1553 }
1554
1555 void addebugtgt_passivereal8array_(char *varname, double *var, int *length) {
1556 adDebugTgt_passiveReal8Array(varname, var, *length) ;
1557 }
1558
1559 void addebugtgt_passivereal4array_(char *varname, float *var, int *length) {
1560 adDebugTgt_passiveReal4Array(varname, var, *length) ;
1561 }
1562
1563 void addebugtgt_testcomplex16_(char *varname, cdcmplx *var, cdcmplx *vard) {
1564 adDebugTgt_testComplex16(varname, *var, vard) ;
1565 }
1566
1567 void addebugtgt_testreal8_(char *varname, double *var, double *vard) {
1568 adDebugTgt_testReal8(varname, *var, vard) ;
1569 }
1570
1571 void addebugtgt_testreal4_(char *varname, float *var, float *vard) {
1572 adDebugTgt_testReal4(varname, *var, vard) ;
1573 }
1574
1575 void addebugtgt_testcomplex16array_(char *varname, cdcmplx* var, cdcmplx* vard, int *length) {
1576 adDebugTgt_testComplex16Array(varname, var, vard, *length) ;
1577 }
1578
1579 void addebugtgt_testreal8array_(char *varname, double* var, double* vard, int *length) {
1580 adDebugTgt_testReal8Array(varname, var, vard, *length) ;
1581 }
1582
1583 void addebugtgt_testreal4array_(char *varname, float* var, float* vard, int *length) {
1584 adDebugTgt_testReal4Array(varname, var, vard, *length) ;
1585 }
1586
1587 void addebugtgt_concludecomplex16_(char* varname, cdcmplx *dep, cdcmplx *depd) {
1588 adDebugTgt_concludeComplex16(varname, *dep, depd) ;
1589 }
1590
1591 void addebugtgt_concludereal8_(char* varname, double *dep, double *depd) {
1592 adDebugTgt_concludeReal8(varname, *dep, depd) ;
1593 }
1594
1595 void addebugtgt_concludereal4_(char* varname, float *dep, float *depd) {
1596 adDebugTgt_concludeReal4(varname, *dep, depd) ;
1597 }
1598
1599 void addebugtgt_concludecomplex16array_(char* varname, cdcmplx *dep, cdcmplx *depd, int *length) {
1600 adDebugTgt_concludeComplex16Array(varname, dep, depd, *length) ;
1601 }
1602
1603 void addebugtgt_concludereal8array_(char* varname, double *dep, double *depd, int *length) {
1604 adDebugTgt_concludeReal8Array(varname, dep, depd, *length) ;
1605 }
1606
1607 void addebugtgt_concludereal4array_(char* varname, float *dep, float *depd, int *length) {
1608 adDebugTgt_concludeReal4Array(varname, dep, depd, *length) ;
1609 }
1610
1611 void addebugtgt_conclude_() {
1612 adDebugTgt_conclude() ;
1613 }
1614
1615 void addebugtgt_display_(char *placename) {
1616 adDebugTgt_display(placename) ;
1617 }
1618
1619 void addebugbwd_init_(double *errmax, double *seed) {
1620 adDebugBwd_init(*errmax, *seed) ;
1621 }
1622
1623 void addebugbwd_call_(char *funcname, int *deltadepth) {
1624 adDebugBwd_call(funcname, *deltadepth) ;
1625 }
1626
1627 void addebugbwd_exit_() {
1628 adDebugBwd_exit() ;
1629 }
1630
1631 int addebugbwd_here_(char* placename) {
1632 return adDebugBwd_here(placename) ;
1633 }
1634
1635 void addebugfwd_init_(double *errmax, double *seed) {
1636 adDebugFwd_init(*errmax, *seed) ;
1637 }
1638
1639 void addebugfwd_call_(char *funcname) {
1640 adDebugFwd_call(funcname) ;
1641 }
1642
1643 void addebugfwd_exit_() {
1644 adDebugFwd_exit() ;
1645 }
1646
1647 int addebugfwd_here_(char* placename) {
1648 return adDebugFwd_here(placename) ;
1649 }
1650
1651 void addebugadj_rwreal4_(float *vard) {
1652 adDebugAdj_rwReal4(vard) ;
1653 }
1654
1655 void addebugadj_rwreal8_(double *vard) {
1656 adDebugAdj_rwReal8(vard) ;
1657 }
1658
1659 void addebugadj_rwcomplex16_(cdcmplx *vard) {
1660 adDebugAdj_rwComplex16(vard) ;
1661 }
1662
1663 void addebugadj_rreal4_(float *vard) {
1664 adDebugAdj_rReal4(vard) ;
1665 }
1666
1667 void addebugadj_rreal8_(double *vard) {
1668 adDebugAdj_rReal8(vard) ;
1669 }
1670
1671 void addebugadj_rcomplex16_(cdcmplx *vard) {
1672 adDebugAdj_rComplex16(vard) ;
1673 }
1674
1675 void addebugadj_wreal4_(float *vard) {
1676 adDebugAdj_wReal4(vard) ;
1677 }
1678
1679 void addebugadj_wreal8_(double *vard) {
1680 adDebugAdj_wReal8(vard) ;
1681 }
1682
1683 void addebugadj_wcomplex16_(cdcmplx *vard) {
1684 adDebugAdj_wComplex16(vard) ;
1685 }
1686
1687 void addebugadj_rwreal4array_(float *vard, int *length) {
1688 adDebugAdj_rwReal4Array(vard, *length) ;
1689 }
1690
1691 void addebugadj_rwreal8array_(double *vard, int *length) {
1692 adDebugAdj_rwReal8Array(vard, *length) ;
1693 }
1694
1695 void addebugadj_rwcomplex16array_(cdcmplx *vard, int *length) {
1696 adDebugAdj_rwComplex16Array(vard, *length) ;
1697 }
1698
1699 void addebugadj_rreal4array_(float *vard, int *length) {
1700 adDebugAdj_rReal4Array(vard, *length) ;
1701 }
1702
1703 void addebugadj_rreal8array_(double *vard, int *length) {
1704 adDebugAdj_rReal8Array(vard, *length) ;
1705 }
1706
1707 void addebugadj_rcomplex16array_(cdcmplx *vard, int *length) {
1708 adDebugAdj_rComplex16Array(vard, *length) ;
1709 }
1710
1711 void addebugadj_wreal4array_(float *vard, int *length) {
1712 adDebugAdj_wReal4Array(vard, *length) ;
1713 }
1714
1715 void addebugadj_wreal8array_(double *vard, int *length) {
1716 adDebugAdj_wReal8Array(vard, *length) ;
1717 }
1718
1719 void addebugadj_wcomplex16array_(cdcmplx *vard, int *length) {
1720 adDebugAdj_wComplex16Array(vard, *length) ;
1721 }
1722
1723 void addebugadj_rwdisplay_(char *placename, int *indent) {
1724 adDebugAdj_rwDisplay(placename, *indent) ;
1725 }
1726
1727 void addebugadj_rdisplay_(char *placename, int *indent) {
1728 adDebugAdj_rDisplay(placename, *indent) ;
1729 }
1730
1731 void addebugadj_wdisplay_(char *placename, int *indent) {
1732 adDebugAdj_wDisplay(placename, *indent) ;
1733 }
1734
1735 void addebugadj_skip_(char* placename) {
1736 adDebugAdj_skip(placename) ;
1737 }
1738
1739 void addebugadj_conclude_() {
1740 adDebugAdj_conclude() ;
1741 }