| [4d61ad0] | 1 | C PRIMITIVES FOR DEBUGGING THE TANGENT AND ADJOINT CODES GENERATED BY TAPENADE.
|
|---|
| 2 | C These primitives are called by the code produced by Tapenade when using
|
|---|
| 3 | C the differentiation command-line options -debugTGT and -debugADJ.
|
|---|
| 4 |
|
|---|
| 5 | C GLOBAL VARIABLES DEFINED IN debugAD.inc:
|
|---|
| 6 | C-----------------------------------------
|
|---|
| 7 | C dbad_mode is 1 when running divided-differences test to validate the tangent mode
|
|---|
| 8 | C -1 when running dot-product test to validate the adjoint mode.
|
|---|
| 9 | C dbad_phase is 1 for the 1st executable that is called for the test
|
|---|
| 10 | C 2 for the 2nd executable that is called for the test
|
|---|
| 11 | C Both tests are run by calling $> exe1 | exe2
|
|---|
| 12 | C dbad_file is the file that is used to make exe1 communicate towards exe2
|
|---|
| 13 | C by default it is std_out (6) in phase 1, and std_in (5) in phase 2.
|
|---|
| 14 | C It's not actually parametrable, but one may change this
|
|---|
| 15 | C if std_in or std_out are unavailable.
|
|---|
| 16 | C dbad_ddeps is the epsilon used by divided-differences test ONLY.
|
|---|
| 17 | C The test 1st order, not centered.
|
|---|
| 18 | C dbad_ddeps is not used in the dot-product test.
|
|---|
| 19 | C dbad_ddeps is set by DEBUG_TGT_INIT[1,2], as its 1st argument.
|
|---|
| 20 | C dbad_epszero is the absolute value under which a derivative is
|
|---|
| 21 | C considered to be in fact zero. It is used in both tests
|
|---|
| 22 | C to eliminate differences between a zero deriv and an undefined deriv.
|
|---|
| 23 | C dbad_epszero is set by DEBUG_TGT_INIT[1,2], as its 2nd argument,
|
|---|
| 24 | C and by DEBUG_[F,B]WD_INIT, as its 1st argument.
|
|---|
| 25 | C dbad_errormax is the percentage of difference above which a "difference"
|
|---|
| 26 | C message is issued. In divided-differences test, this is about
|
|---|
| 27 | C the comparison of tgt diff wrt divided-differences.
|
|---|
| 28 | C In dot-product mode, this is about the comparison between
|
|---|
| 29 | C the (sum of the) bwd Jacobian wrt the (sum of the) tgt Jacobian.
|
|---|
| 30 | C dbad_errormax is set by DEBUG_TGT_INIT[1,2], as its 3rd argument,
|
|---|
| 31 | C and by DEBUG_[F,B]WD_INIT, as its 2nd argument.
|
|---|
| 32 | C dbad_seed is the increment used to "randomize" the X_d and Y_b used in the
|
|---|
| 33 | C dot-product test. X_d and Y_d are filled with values in [1.d0 , 2.d0[,
|
|---|
| 34 | C starting with 1.d0 and incremented by steps of dbad_seed.
|
|---|
| 35 | C dbad_seed is set by DEBUG_[F,B]WD_INIT, as its 3rd argument.
|
|---|
| 36 | C dbad_callsz is the max depth of nested calls during execution.
|
|---|
| 37 | C It is set by default to 99 in debugAD.inc.
|
|---|
| 38 | C It may be changed in debugAD.inc, if needed.
|
|---|
| 39 | C dbad_callnames is the stack of the procedure names in the current call stack.
|
|---|
| 40 | C These names are stored without the _D or _B extension.
|
|---|
| 41 | C dbad_callcodes is a stack of codes of the current call stack.
|
|---|
| 42 | C It is currently not used and may disappear sone day.
|
|---|
| 43 | C dbad_calltraced is a stack of booleans on the current call stack.
|
|---|
| 44 | C "true" means that the current call is being traced.
|
|---|
| 45 | C A "false" means not traced, and implies a "false" in all
|
|---|
| 46 | C deeper calls. In divided-differences test ONLY, this can be
|
|---|
| 47 | C overriden by passing "true" as the 3rd argument of
|
|---|
| 48 | C DEBUG_TGT_CALL or DEBUG_TGT_HERE.
|
|---|
| 49 |
|
|---|
| 50 | BLOCK DATA DEBUG_AD
|
|---|
| 51 | IMPLICIT NONE
|
|---|
| 52 | INCLUDE 'debugAD.inc'
|
|---|
| 53 | DATA dbad_callindex/0/
|
|---|
| 54 | DATA dbad_sum/0.d0/
|
|---|
| 55 | DATA dbad_coeff/1.d0/
|
|---|
| 56 | DATA dbad_seed/0.137d0/
|
|---|
| 57 | END
|
|---|
| 58 |
|
|---|
| 59 | C DEBUG PRIMITIVES FOR THE TANGENT MODE (DIVIDED-DIFFERENCES METHOD)
|
|---|
| 60 |
|
|---|
| 61 | SUBROUTINE DEBUG_TGT_INIT1(epsilon, ezero, errmax)
|
|---|
| 62 | IMPLICIT NONE
|
|---|
| 63 | REAL*8 epsilon, ezero, errmax
|
|---|
| 64 | INCLUDE 'debugAD.inc'
|
|---|
| 65 | dbad_mode = 1
|
|---|
| 66 | dbad_phase = 1
|
|---|
| 67 | dbad_file = 6
|
|---|
| 68 | dbad_ddeps = epsilon
|
|---|
| 69 | dbad_epszero = ezero
|
|---|
| 70 | dbad_errormax = errmax
|
|---|
| 71 | end
|
|---|
| 72 |
|
|---|
| 73 | SUBROUTINE DEBUG_TGT_INIT2(epsilon, ezero, errmax)
|
|---|
| 74 | IMPLICIT NONE
|
|---|
| 75 | REAL*8 epsilon, ezero, errmax
|
|---|
| 76 | INCLUDE 'debugAD.inc'
|
|---|
| 77 | dbad_mode = 1
|
|---|
| 78 | dbad_phase = 2
|
|---|
| 79 | dbad_file = 5
|
|---|
| 80 | dbad_ddeps = epsilon
|
|---|
| 81 | dbad_epszero = ezero
|
|---|
| 82 | dbad_errormax = errmax
|
|---|
| 83 | write (*,'("Starting TGT test, epsilon=",e8.1,
|
|---|
| 84 | + ", zero=",e8.1,", errmax=",f4.1,"%")'),
|
|---|
| 85 | + epsilon,ezero,errmax
|
|---|
| 86 | write (*,
|
|---|
| 87 | +'("===========================================================")')
|
|---|
| 88 | end
|
|---|
| 89 |
|
|---|
| 90 | SUBROUTINE DEBUG_TGT_INITREAL4(indep, indepd)
|
|---|
| 91 | IMPLICIT NONE
|
|---|
| 92 | REAL*4 indep, indepd
|
|---|
| 93 | INCLUDE 'debugAD.inc'
|
|---|
| 94 | if (dbad_phase.eq.1) then
|
|---|
| 95 | indep = indep+dbad_ddeps*indepd
|
|---|
| 96 | endif
|
|---|
| 97 | end
|
|---|
| 98 |
|
|---|
| 99 | SUBROUTINE DEBUG_TGT_INITREAL4ARRAY(indep, indepd, length)
|
|---|
| 100 | IMPLICIT NONE
|
|---|
| 101 | INTEGER length
|
|---|
| 102 | REAL*4 indep(length), indepd(length)
|
|---|
| 103 | INCLUDE 'debugAD.inc'
|
|---|
| 104 | INTEGER i
|
|---|
| 105 | if (dbad_phase.eq.1) then
|
|---|
| 106 | do i=1,length
|
|---|
| 107 | indep(i) = indep(i)+dbad_ddeps*indepd(i)
|
|---|
| 108 | enddo
|
|---|
| 109 | endif
|
|---|
| 110 | end
|
|---|
| 111 |
|
|---|
| 112 | SUBROUTINE DEBUG_TGT_INITREAL8(indep, indepd)
|
|---|
| 113 | IMPLICIT NONE
|
|---|
| 114 | REAL*8 indep, indepd
|
|---|
| 115 | INCLUDE 'debugAD.inc'
|
|---|
| 116 | if (dbad_phase.eq.1) then
|
|---|
| 117 | indep = indep+dbad_ddeps*indepd
|
|---|
| 118 | endif
|
|---|
| 119 | end
|
|---|
| 120 |
|
|---|
| 121 | SUBROUTINE DEBUG_TGT_INITREAL8ARRAY(indep, indepd, length)
|
|---|
| 122 | IMPLICIT NONE
|
|---|
| 123 | INTEGER length
|
|---|
| 124 | REAL*8 indep(length), indepd(length)
|
|---|
| 125 | INCLUDE 'debugAD.inc'
|
|---|
| 126 | INTEGER i
|
|---|
| 127 | if (dbad_phase.eq.1) then
|
|---|
| 128 | do i=1,length
|
|---|
| 129 | indep(i) = indep(i)+dbad_ddeps*indepd(i)
|
|---|
| 130 | enddo
|
|---|
| 131 | endif
|
|---|
| 132 | end
|
|---|
| 133 |
|
|---|
| 134 | SUBROUTINE DEBUG_TGT_CONCLUDEREAL4(varname, var, vard)
|
|---|
| 135 | IMPLICIT NONE
|
|---|
| 136 | character varname*(*)
|
|---|
| 137 | real*4 var, vard
|
|---|
| 138 | INCLUDE 'debugAD.inc'
|
|---|
| 139 | REAL*4 ddvar, dd, diff, varwr
|
|---|
| 140 | LOGICAL areNaNs
|
|---|
| 141 | if (dbad_phase.eq.1) then
|
|---|
| 142 | write (dbad_file, '(a)') 'final_result'
|
|---|
| 143 | write (dbad_file, *) var
|
|---|
| 144 | else
|
|---|
| 145 | call DDCHECKVARNAME('final_result')
|
|---|
| 146 | call DDPICKTWO4(var, varwr, dbad_file, ddvar, areNaNs)
|
|---|
| 147 | if (.not.areNaNs) then
|
|---|
| 148 | dd = (ddvar-varwr)/dbad_ddeps
|
|---|
| 149 | diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
|
|---|
| 150 | write (*,'("Final result",a20,": ",e20.8," (ad)",
|
|---|
| 151 | + f9.5,"% DIFF WITH (dd) ",e20.8)')
|
|---|
| 152 | + varname,vard,diff,dd
|
|---|
| 153 | else
|
|---|
| 154 | write (*, '(a)') 'Final result has NaNs'
|
|---|
| 155 | endif
|
|---|
| 156 | endif
|
|---|
| 157 | write (*,
|
|---|
| 158 | +'("===========================================================")')
|
|---|
| 159 | END
|
|---|
| 160 |
|
|---|
| 161 | SUBROUTINE DEBUG_TGT_CONCLUDEREAL4ARRAY
|
|---|
| 162 | + (varname, tvar, tvard, length)
|
|---|
| 163 | IMPLICIT NONE
|
|---|
| 164 | integer length
|
|---|
| 165 | real*4 tvar(length)
|
|---|
| 166 | real*4 tvard(length)
|
|---|
| 167 | character varname*(*)
|
|---|
| 168 | REAL*4 var, vard
|
|---|
| 169 | INTEGER i
|
|---|
| 170 | var = 0.0
|
|---|
| 171 | vard = 0.0
|
|---|
| 172 | DO i=1,length
|
|---|
| 173 | var = var + tvar(i)
|
|---|
| 174 | vard = vard + tvard(i)
|
|---|
| 175 | ENDDO
|
|---|
| 176 | call DEBUG_TGT_CONCLUDEREAL4(varname, var, vard)
|
|---|
| 177 | END
|
|---|
| 178 |
|
|---|
| 179 | SUBROUTINE DEBUG_TGT_CONCLUDEREAL8(varname, var, vard)
|
|---|
| 180 | IMPLICIT NONE
|
|---|
| 181 | character varname*(*)
|
|---|
| 182 | real*8 var, vard
|
|---|
| 183 | INCLUDE 'debugAD.inc'
|
|---|
| 184 | REAL*8 ddvar, dd, diff, varwr
|
|---|
| 185 | LOGICAL areNaNs
|
|---|
| 186 | if (dbad_phase.eq.1) then
|
|---|
| 187 | write (dbad_file, '(a)') 'final_result'
|
|---|
| 188 | write (dbad_file, *) var
|
|---|
| 189 | else
|
|---|
| 190 | call DDCHECKVARNAME('final_result')
|
|---|
| 191 | call DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
|
|---|
| 192 | if (.not.areNaNs) then
|
|---|
| 193 | dd = (ddvar-varwr)/dbad_ddeps
|
|---|
| 194 | diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
|
|---|
| 195 | write (*,'("Final result",a20,": ",e24.16," (ad)",
|
|---|
| 196 | + f9.5,"% DIFF WITH (dd) ",e24.16)')
|
|---|
| 197 | + varname,vard,diff,dd
|
|---|
| 198 | else
|
|---|
| 199 | write (*, '(a)') 'Final result has NaNs'
|
|---|
| 200 | endif
|
|---|
| 201 | endif
|
|---|
| 202 | write (*,
|
|---|
| 203 | +'("===========================================================")')
|
|---|
| 204 | END
|
|---|
| 205 |
|
|---|
| 206 | SUBROUTINE DEBUG_TGT_CONCLUDEREAL8ARRAY
|
|---|
| 207 | + (varname, tvar, tvard, length)
|
|---|
| 208 | IMPLICIT NONE
|
|---|
| 209 | integer length
|
|---|
| 210 | real*8 tvar(length)
|
|---|
| 211 | real*8 tvard(length)
|
|---|
| 212 | character varname*(*)
|
|---|
| 213 | REAL*8 var, vard
|
|---|
| 214 | INTEGER i
|
|---|
| 215 | var = 0.d0
|
|---|
| 216 | vard = 0.d0
|
|---|
| 217 | DO i=1,length
|
|---|
| 218 | var = var + tvar(i)
|
|---|
| 219 | vard = vard + tvard(i)
|
|---|
| 220 | ENDDO
|
|---|
| 221 | call DEBUG_TGT_CONCLUDEREAL8(varname, var, vard)
|
|---|
| 222 | END
|
|---|
| 223 |
|
|---|
| 224 | SUBROUTINE DEBUG_TGT_CALL(unitname, traced, forcetraced)
|
|---|
| 225 | IMPLICIT NONE
|
|---|
| 226 | CHARACTER unitname*(*)
|
|---|
| 227 | LOGICAL traced, forcetraced
|
|---|
| 228 | INCLUDE 'debugAD.inc'
|
|---|
| 229 | dbad_callindex = dbad_callindex+1
|
|---|
| 230 | write (dbad_callnames(dbad_callindex),'(a40)') unitname
|
|---|
| 231 | dbad_calltraced(dbad_callindex) =
|
|---|
| 232 | + ((dbad_callindex.eq.1.OR.
|
|---|
| 233 | + dbad_calltraced(dbad_callindex-1))
|
|---|
| 234 | + .AND.traced) .OR. forcetraced
|
|---|
| 235 | END
|
|---|
| 236 |
|
|---|
| 237 | SUBROUTINE DEBUG_TGT_EXIT()
|
|---|
| 238 | IMPLICIT NONE
|
|---|
| 239 | INCLUDE 'debugAD.inc'
|
|---|
| 240 | dbad_callindex = dbad_callindex-1
|
|---|
| 241 | END
|
|---|
| 242 |
|
|---|
| 243 | LOGICAL FUNCTION DEBUG_TGT_HERE(placename, forcetraced)
|
|---|
| 244 | IMPLICIT NONE
|
|---|
| 245 | CHARACTER placename*(*)
|
|---|
| 246 | LOGICAL forcetraced
|
|---|
| 247 | INCLUDE 'debugAD.inc'
|
|---|
| 248 | DEBUG_TGT_HERE =
|
|---|
| 249 | + (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex))
|
|---|
| 250 | + .OR.forcetraced
|
|---|
| 251 | RETURN
|
|---|
| 252 | END
|
|---|
| 253 |
|
|---|
| 254 | SUBROUTINE DEBUG_TGT_REAL4(varname, var, vard)
|
|---|
| 255 | IMPLICIT NONE
|
|---|
| 256 | character varname*(*)
|
|---|
| 257 | REAL*4 var, vard
|
|---|
| 258 | INCLUDE 'debugAD.inc'
|
|---|
| 259 | REAL*4 ddvar, dd, diff, varwr
|
|---|
| 260 | LOGICAL areNaNs
|
|---|
| 261 | character*12 diffstr
|
|---|
| 262 | character*50 ddvarname
|
|---|
| 263 | if (dbad_phase.eq.1) then
|
|---|
| 264 | WRITE(dbad_file, '(a)') varname
|
|---|
| 265 | WRITE(dbad_file, *) var
|
|---|
| 266 | else if (dbad_phase.eq.2) then
|
|---|
| 267 | call DDCHECKVARNAME(varname)
|
|---|
| 268 | call DDPICKTWO4(var, varwr, dbad_file, ddvar, areNaNs)
|
|---|
| 269 | if (.not.areNaNs) then
|
|---|
| 270 | dd = (ddvar-varwr)/dbad_ddeps
|
|---|
| 271 | if ((abs(vard).gt.dbad_epszero)
|
|---|
| 272 | + .or.(abs(dd).gt.dbad_epszero)) then
|
|---|
| 273 | diff = (abs(vard-dd)*100.0)/max(abs(vard),abs(dd))
|
|---|
| 274 | if (diff.gt.dbad_errormax) then
|
|---|
| 275 | diffstr = 'DIFFERENCE!!'
|
|---|
| 276 | else
|
|---|
| 277 | diffstr = ' '
|
|---|
| 278 | endif
|
|---|
| 279 | write (*,'(" ", a,":",e11.4,
|
|---|
| 280 | + " (dd:",e11.4,") ",a14)')
|
|---|
| 281 | + varname, vard, dd, diffstr
|
|---|
| 282 | endif
|
|---|
| 283 | endif
|
|---|
| 284 | endif
|
|---|
| 285 | END
|
|---|
| 286 |
|
|---|
| 287 | SUBROUTINE DEBUG_TGT_REAL4ARRAY (varname, var, vard, length)
|
|---|
| 288 | IMPLICIT NONE
|
|---|
| 289 | integer length
|
|---|
| 290 | real*4 var(length)
|
|---|
| 291 | real*4 vard(length)
|
|---|
| 292 | character varname*(*)
|
|---|
| 293 | INCLUDE 'debugAD.inc'
|
|---|
| 294 | real*4 ddvar, dd, diff, varwr
|
|---|
| 295 | real*4 valbuf(10),ddbuf(10)
|
|---|
| 296 | character*50 ddvarname
|
|---|
| 297 | integer indexbuf1(10)
|
|---|
| 298 | character*14 diffbuf(10)
|
|---|
| 299 | integer i1,j
|
|---|
| 300 | integer ibuf
|
|---|
| 301 | logical notprintedheader
|
|---|
| 302 | LOGICAL areNaNs
|
|---|
| 303 | if (dbad_phase.eq.1) then
|
|---|
| 304 | WRITE(dbad_file, '(a)') varname
|
|---|
| 305 | do i1=1,length
|
|---|
| 306 | WRITE(dbad_file, *) var(i1)
|
|---|
| 307 | enddo
|
|---|
| 308 | else if (dbad_phase.eq.2) then
|
|---|
| 309 | call DDCHECKVARNAME(varname)
|
|---|
| 310 | notprintedheader=.true.
|
|---|
| 311 | ibuf = 1
|
|---|
| 312 | do i1=1,length
|
|---|
| 313 | call DDPICKTWO4(var(i1),varwr,dbad_file,ddvar,areNaNs)
|
|---|
| 314 | if (.not.areNaNs) then
|
|---|
| 315 | dd = (ddvar-varwr)/dbad_ddeps
|
|---|
| 316 | if ((abs(vard(i1)).gt.dbad_epszero)
|
|---|
| 317 | + .or.(abs(dd).gt.dbad_epszero)) then
|
|---|
| 318 | valbuf(ibuf) = vard(i1)
|
|---|
| 319 | ddbuf(ibuf) = dd
|
|---|
| 320 | indexbuf1(ibuf) = i1
|
|---|
| 321 | diff = (abs(vard(i1)-dd)*100.0)
|
|---|
| 322 | + /max(abs(vard(i1)),abs(dd))
|
|---|
| 323 | if (diff.gt.dbad_errormax) then
|
|---|
| 324 | diffbuf(ibuf) = ' DIFFERENCE!!'
|
|---|
| 325 | ibuf = ibuf+1
|
|---|
| 326 | else
|
|---|
| 327 | ! diffbuf(ibuf) = ' '
|
|---|
| 328 | ! ibuf = ibuf+1
|
|---|
| 329 | endif
|
|---|
| 330 | endif
|
|---|
| 331 | endif
|
|---|
| 332 | if(ibuf.gt.10.or.(i1.eq.length.and.ibuf.gt.1)) then
|
|---|
| 333 | if (notprintedheader) then
|
|---|
| 334 | write(*,'(" ", a, ":")') varname
|
|---|
| 335 | notprintedheader=.false.
|
|---|
| 336 | endif
|
|---|
| 337 | write (*, '(" ", 10(i4,"->",e11.4))')
|
|---|
| 338 | + (indexbuf1(j),valbuf(j), j=1,ibuf-1)
|
|---|
| 339 | write (*, '(" (dd:)", 10(" (",e11.4,")"))')
|
|---|
| 340 | + (ddbuf(j), j=1,ibuf-1)
|
|---|
| 341 | write (*, '(" ", 10(a16))')
|
|---|
| 342 | + (diffbuf(j), j=1,ibuf-1)
|
|---|
| 343 | ibuf = 1
|
|---|
| 344 | endif
|
|---|
| 345 | end do
|
|---|
| 346 | endif
|
|---|
| 347 | END
|
|---|
| 348 |
|
|---|
| 349 | SUBROUTINE DDPICKTWO4(var, varwr, dbad_file, ddvar, areNaNs)
|
|---|
| 350 | IMPLICIT NONE
|
|---|
| 351 | REAL*4 var,varwr,ddvar
|
|---|
| 352 | LOGICAL areNaNs
|
|---|
| 353 | INTEGER dbad_file,stat1,stat2
|
|---|
| 354 | OPEN(38, FILE='ddwrfile')
|
|---|
| 355 | WRITE(38, *) var
|
|---|
| 356 | REWIND(38)
|
|---|
| 357 | READ(38, *,IOSTAT=stat1) varwr
|
|---|
| 358 | CLOSE(38)
|
|---|
| 359 | READ(dbad_file, *,IOSTAT=stat2) ddvar
|
|---|
| 360 | areNaNs = stat1.eq.225.and.stat2.eq.225
|
|---|
| 361 | END
|
|---|
| 362 |
|
|---|
| 363 | SUBROUTINE DEBUG_TGT_REAL8(varname, var, vard)
|
|---|
| 364 | IMPLICIT NONE
|
|---|
| 365 | CHARACTER varname*(*)
|
|---|
| 366 | REAL*8 var, vard
|
|---|
| 367 | INCLUDE 'debugAD.inc'
|
|---|
| 368 | REAL*8 ddvar, dd, diff, varwr
|
|---|
| 369 | character*12 diffstr
|
|---|
| 370 | character*50 ddvarname
|
|---|
| 371 | LOGICAL areNaNs
|
|---|
| 372 | if (dbad_phase.eq.1) then
|
|---|
| 373 | WRITE(dbad_file, '(a)') varname
|
|---|
| 374 | WRITE(dbad_file, *) var
|
|---|
| 375 | else if (dbad_phase.eq.2) then
|
|---|
| 376 | call DDCHECKVARNAME(varname)
|
|---|
| 377 | call DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
|
|---|
| 378 | if (.not.areNaNs) then
|
|---|
| 379 | dd = (ddvar-varwr)/dbad_ddeps
|
|---|
| 380 | if ((abs(vard).gt.dbad_epszero)
|
|---|
| 381 | + .or.(abs(dd).gt.dbad_epszero)) then
|
|---|
| 382 | diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
|
|---|
| 383 | if (diff.gt.dbad_errormax) then
|
|---|
| 384 | diffstr = 'DIFFERENCE!!'
|
|---|
| 385 | write (*,'(a20,": ",e24.16," (ad)",
|
|---|
| 386 | + f5.1,"% DIFF WITH (dd) ",e24.16)')
|
|---|
| 387 | + varname, vard, diff, dd
|
|---|
| 388 | else
|
|---|
| 389 | diffstr = ' '
|
|---|
| 390 | endif
|
|---|
| 391 | ! write (*,*) ddvar,varwr,dd,'=?=',vard,' %',diff,varname
|
|---|
| 392 | ! write (*,*) varname, vard, 'dd:', dd, diffstr
|
|---|
| 393 | endif
|
|---|
| 394 | endif
|
|---|
| 395 | endif
|
|---|
| 396 | END
|
|---|
| 397 |
|
|---|
| 398 | SUBROUTINE DEBUG_TGT_REAL8v(varname, var, vard)
|
|---|
| 399 | IMPLICIT NONE
|
|---|
| 400 | CHARACTER varname*(*)
|
|---|
| 401 | REAL*8 var, vard
|
|---|
| 402 | INCLUDE 'debugAD.inc'
|
|---|
| 403 | REAL*8 ddvar, dd, diff, varwr
|
|---|
| 404 | character*12 diffstr
|
|---|
| 405 | character*50 ddvarname
|
|---|
| 406 | LOGICAL areNaNs
|
|---|
| 407 | if (dbad_phase.eq.1) then
|
|---|
| 408 | WRITE(dbad_file, '(a)') varname
|
|---|
| 409 | WRITE(dbad_file, *) var
|
|---|
| 410 | else if (dbad_phase.eq.2) then
|
|---|
| 411 | call DDCHECKVARNAME(varname)
|
|---|
| 412 | call DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
|
|---|
| 413 | if (.not.areNaNs) then
|
|---|
| 414 | dd = (ddvar-varwr)/dbad_ddeps
|
|---|
| 415 | if ((abs(vard).gt.dbad_epszero)
|
|---|
| 416 | + .or.(abs(dd).gt.dbad_epszero)) then
|
|---|
| 417 | diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
|
|---|
| 418 | if (diff.gt.dbad_errormax) then
|
|---|
| 419 | diffstr = 'DIFFERENCE!!'
|
|---|
| 420 | write (*,'(a20,": ",e24.16," (ad)",
|
|---|
| 421 | + f5.1,"% DIFF WITH (dd) ",e24.16)')
|
|---|
| 422 | + varname, vard, diff, dd
|
|---|
| 423 | else
|
|---|
| 424 | diffstr = ' '
|
|---|
| 425 | endif
|
|---|
| 426 | write (*,*) varname,ddvar,varwr,dd,'=?=',vard,' %',diff
|
|---|
| 427 | else
|
|---|
| 428 | write (*,*) varname,ddvar,varwr,dd,'=?zero?=',vard
|
|---|
| 429 | endif
|
|---|
| 430 | endif
|
|---|
| 431 | endif
|
|---|
| 432 | END
|
|---|
| 433 |
|
|---|
| 434 | SUBROUTINE DEBUG_TGT_REAL8ARRAY(varname, var, vard, length)
|
|---|
| 435 | IMPLICIT NONE
|
|---|
| 436 | integer length
|
|---|
| 437 | real*8 var(length)
|
|---|
| 438 | real*8 vard(length)
|
|---|
| 439 | character varname*(*)
|
|---|
| 440 | INCLUDE 'debugAD.inc'
|
|---|
| 441 | LOGICAL areNaNs
|
|---|
| 442 | real*8 ddvar, dd, diff, varwr
|
|---|
| 443 | real*8 valbuf(10),ddbuf(10)
|
|---|
| 444 | character*50 ddvarname
|
|---|
| 445 | integer indexbuf1(10)
|
|---|
| 446 | character*14 diffbuf(10)
|
|---|
| 447 | integer i1,j
|
|---|
| 448 | integer ibuf
|
|---|
| 449 | logical notprintedheader
|
|---|
| 450 | if (dbad_phase.eq.1) then
|
|---|
| 451 | WRITE(dbad_file, '(a)') varname
|
|---|
| 452 | do i1=1,length
|
|---|
| 453 | WRITE(dbad_file, *) var(i1)
|
|---|
| 454 | enddo
|
|---|
| 455 | else if (dbad_phase.eq.2) then
|
|---|
| 456 | call DDCHECKVARNAME(varname)
|
|---|
| 457 | notprintedheader=.true.
|
|---|
| 458 | ibuf = 1
|
|---|
| 459 | do i1=1,length
|
|---|
| 460 | call DDPICKTWO8(var(i1),varwr,dbad_file,ddvar,areNaNs)
|
|---|
| 461 | if (.not.areNaNs) then
|
|---|
| 462 | dd = (ddvar-varwr)/dbad_ddeps
|
|---|
| 463 | if ((abs(vard(i1)).gt.dbad_epszero)
|
|---|
| 464 | + .or.(abs(dd).gt.dbad_epszero)) then
|
|---|
| 465 | valbuf(ibuf) = vard(i1)
|
|---|
| 466 | ddbuf(ibuf) = dd
|
|---|
| 467 | indexbuf1(ibuf) = i1
|
|---|
| 468 | diff = (abs(vard(i1)-dd)*100.0)
|
|---|
| 469 | + /max(abs(vard(i1)),abs(dd))
|
|---|
| 470 | if (diff.gt.dbad_errormax) then
|
|---|
| 471 | diffbuf(ibuf) = ' DIFFERENCE!!'
|
|---|
| 472 | ibuf = ibuf+1
|
|---|
| 473 | else
|
|---|
| 474 | ! diffbuf(ibuf) = ' '
|
|---|
| 475 | ! ibuf = ibuf+1
|
|---|
| 476 | endif
|
|---|
| 477 | endif
|
|---|
| 478 | endif
|
|---|
| 479 | if(ibuf.gt.10.or.(i1.eq.length.and.ibuf.gt.1)) then
|
|---|
| 480 | if (notprintedheader) then
|
|---|
| 481 | write(*,'(" ", a, ":")') varname
|
|---|
| 482 | notprintedheader=.false.
|
|---|
| 483 | endif
|
|---|
| 484 | write (*, '(" ", 10(i4,"->",e11.4))')
|
|---|
| 485 | + (indexbuf1(j),valbuf(j), j=1,ibuf-1)
|
|---|
| 486 | write (*, '(" (dd:)", 10(" (",e11.4,")"))')
|
|---|
| 487 | + (ddbuf(j), j=1,ibuf-1)
|
|---|
| 488 | write (*, '(" ", 10(a16))')
|
|---|
| 489 | + (diffbuf(j), j=1,ibuf-1)
|
|---|
| 490 | ibuf = 1
|
|---|
| 491 | endif
|
|---|
| 492 | end do
|
|---|
| 493 | endif
|
|---|
| 494 | END
|
|---|
| 495 |
|
|---|
| 496 | SUBROUTINE DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
|
|---|
| 497 | IMPLICIT NONE
|
|---|
| 498 | REAL*8 var,varwr,ddvar
|
|---|
| 499 | LOGICAL areNaNs
|
|---|
| 500 | INTEGER dbad_file,stat1,stat2
|
|---|
| 501 | OPEN(38, FILE='ddwrfile')
|
|---|
| 502 | WRITE(38, *) var
|
|---|
| 503 | REWIND(38)
|
|---|
| 504 | READ(38, *,IOSTAT=stat1) varwr
|
|---|
| 505 | CLOSE(38)
|
|---|
| 506 | READ(dbad_file, *,IOSTAT=stat2) ddvar
|
|---|
| 507 | areNaNs = stat1.eq.225.and.stat2.eq.225
|
|---|
| 508 | END
|
|---|
| 509 |
|
|---|
| 510 | SUBROUTINE DDCHECKVARNAME(varname)
|
|---|
| 511 | IMPLICIT NONE
|
|---|
| 512 | character varname*(*)
|
|---|
| 513 | INCLUDE 'debugAD.inc'
|
|---|
| 514 | character*50 ddvarname
|
|---|
| 515 | integer linesskip
|
|---|
| 516 | linesskip = 0
|
|---|
| 517 | 100 CONTINUE
|
|---|
| 518 | if (linesskip.GT.990000) THEN
|
|---|
| 519 | write(*,*)
|
|---|
| 520 | + 'ERROR: Too many lines skipped. Bad DD program control ?'
|
|---|
| 521 | write(*,*) 'Was looking for variable:',varname
|
|---|
| 522 | STOP
|
|---|
| 523 | ENDIF
|
|---|
| 524 | READ(dbad_file, '(a)') ddvarname
|
|---|
| 525 | if (ddvarname.ne.varname) then
|
|---|
| 526 | ! write(*,*) 'ERROR: mismatch in DD program control !!!',
|
|---|
| 527 | ! + ' read ', ddvarname, ' expecting ', varname
|
|---|
| 528 | linesskip = linesskip+1
|
|---|
| 529 | GOTO 100
|
|---|
| 530 | endif
|
|---|
| 531 | END
|
|---|
| 532 |
|
|---|
| 533 | SUBROUTINE DEBUG_TGT_DISPLAY(placename)
|
|---|
| 534 | IMPLICIT NONE
|
|---|
| 535 | CHARACTER placename*(*)
|
|---|
| 536 | INCLUDE 'debugAD.inc'
|
|---|
| 537 | if (dbad_phase.eq.2) then
|
|---|
| 538 | CALL DEBUG_DISPLAY_LOCATION(placename)
|
|---|
| 539 | endif
|
|---|
| 540 | END
|
|---|
| 541 |
|
|---|
| 542 | C DEBUG PRIMITIVES FOR THE ADJOINT MODE, BACKWARD SWEEP (DOT-PRODUCT METHOD)
|
|---|
| 543 |
|
|---|
| 544 | SUBROUTINE DEBUG_BWD_INIT(ezero, errmax, seed)
|
|---|
| 545 | IMPLICIT NONE
|
|---|
| 546 | REAL*8 ezero, errmax, seed
|
|---|
| 547 | INCLUDE 'debugAD.inc'
|
|---|
| 548 | dbad_mode = -1
|
|---|
| 549 | dbad_phase = 1
|
|---|
| 550 | dbad_file = 6
|
|---|
| 551 | dbad_epszero = ezero
|
|---|
| 552 | dbad_errormax = errmax
|
|---|
| 553 | dbad_seed = seed
|
|---|
| 554 | write(dbad_file,'(i3,a40)') 3, 'StartOfPhase1'
|
|---|
| 555 | END
|
|---|
| 556 |
|
|---|
| 557 | SUBROUTINE DEBUG_BWD_CONCLUDE()
|
|---|
| 558 | IMPLICIT NONE
|
|---|
| 559 | INCLUDE 'debugAD.inc'
|
|---|
| 560 | REAL*8 sumd
|
|---|
| 561 | INTEGER*4 smallsize, nbblocks, SMALLSTACKSIZE
|
|---|
| 562 | INTEGER*4 nbreals, i
|
|---|
| 563 | write(dbad_file,'(i3,a40)') -3, 'EndOfPhase1'
|
|---|
| 564 | END
|
|---|
| 565 |
|
|---|
| 566 | SUBROUTINE DEBUG_BWD_CALL(unitname, traced)
|
|---|
| 567 | IMPLICIT NONE
|
|---|
| 568 | CHARACTER unitname*(*)
|
|---|
| 569 | LOGICAL traced
|
|---|
| 570 | INCLUDE 'debugAD.inc'
|
|---|
| 571 | dbad_callindex = dbad_callindex+1
|
|---|
| 572 | write (dbad_callnames(dbad_callindex),'(a40)') unitname
|
|---|
| 573 | dbad_calltraced(dbad_callindex) =
|
|---|
| 574 | + (dbad_callindex.eq.1.OR.
|
|---|
| 575 | + dbad_calltraced(dbad_callindex-1))
|
|---|
| 576 | + .AND.traced
|
|---|
| 577 | end
|
|---|
| 578 |
|
|---|
| 579 | SUBROUTINE DEBUG_BWD_EXIT()
|
|---|
| 580 | IMPLICIT NONE
|
|---|
| 581 | INCLUDE 'debugAD.inc'
|
|---|
| 582 | IF (dbad_callindex.eq.1 .OR.
|
|---|
| 583 | + dbad_calltraced(dbad_callindex-1)) THEN
|
|---|
| 584 | IF (dbad_calltraced(dbad_callindex)) THEN
|
|---|
| 585 | write(dbad_file,'(i3,a40)')
|
|---|
| 586 | + 2, dbad_callnames(dbad_callindex)
|
|---|
| 587 | ELSE
|
|---|
| 588 | write(dbad_file,'(i3,a40)')
|
|---|
| 589 | + -2, dbad_callnames(dbad_callindex)
|
|---|
| 590 | ENDIF
|
|---|
| 591 | ENDIF
|
|---|
| 592 | dbad_callindex = dbad_callindex-1
|
|---|
| 593 | END
|
|---|
| 594 |
|
|---|
| 595 | LOGICAL FUNCTION DEBUG_BWD_HERE(placename)
|
|---|
| 596 | IMPLICIT NONE
|
|---|
| 597 | CHARACTER placename*(*)
|
|---|
| 598 | INCLUDE 'debugAD.inc'
|
|---|
| 599 | DEBUG_BWD_HERE =
|
|---|
| 600 | + (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex))
|
|---|
| 601 | RETURN
|
|---|
| 602 | END
|
|---|
| 603 |
|
|---|
| 604 | C DEBUG PRIMITIVES FOR THE ADJOINT MODE, FORWARD SWEEP (DOT-PRODUCT METHOD)
|
|---|
| 605 |
|
|---|
| 606 | SUBROUTINE DEBUG_FWD_INIT(ezero, errmax, seed)
|
|---|
| 607 | IMPLICIT NONE
|
|---|
| 608 | REAL*8 ezero, errmax, seed
|
|---|
| 609 | INCLUDE 'debugAD.inc'
|
|---|
| 610 | INTEGER label
|
|---|
| 611 | CHARACTER*40 startstring
|
|---|
| 612 | CHARACTER*40 placestring
|
|---|
| 613 | REAL*8 bigsum
|
|---|
| 614 | dbad_mode = -1
|
|---|
| 615 | dbad_phase = 2
|
|---|
| 616 | dbad_file = 5
|
|---|
| 617 | dbad_epszero = ezero
|
|---|
| 618 | dbad_errormax = errmax
|
|---|
| 619 | dbad_seed = seed
|
|---|
| 620 | dbad_nberrors = 0
|
|---|
| 621 | write (*,'("Starting ADJ test, zero=",e8.1,
|
|---|
| 622 | + ", errmax=",f4.1,"%, seed=",f5.3)'),
|
|---|
| 623 | + ezero,errmax,seed
|
|---|
| 624 | write (*,
|
|---|
| 625 | +'("===========================================================")')
|
|---|
| 626 | C labels: 3 -> StartOfPhase1
|
|---|
| 627 | C -1 -> a debug point, skipped
|
|---|
| 628 | C 0 -> a debug point, traced but no associated value.
|
|---|
| 629 | C 1 -> a debug point, traced, with an associated value.
|
|---|
| 630 | C -2 -> a call, skipped
|
|---|
| 631 | C 2 -> a call, traced
|
|---|
| 632 | C -3 -> EndOfPhase1
|
|---|
| 633 | 100 READ(dbad_file,'(i3,a40)',ERR=200,END=500) label,startstring
|
|---|
| 634 | if (label.eq.3.AND.
|
|---|
| 635 | + startstring.EQ.' StartOfPhase1')
|
|---|
| 636 | + GOTO 300
|
|---|
| 637 | 200 GOTO 100
|
|---|
| 638 | 300 CALL PUSHINTEGER4(3)
|
|---|
| 639 | 400 READ(dbad_file,'(i3,a40)',ERR=500,END=500) label,placestring
|
|---|
| 640 | IF (label.eq.-3) GOTO 500
|
|---|
| 641 | IF (label.eq.1) THEN
|
|---|
| 642 | READ(dbad_file,*) bigsum
|
|---|
| 643 | CALL PUSHREAL8(bigsum)
|
|---|
| 644 | ENDIF
|
|---|
| 645 | CALL PUSHCHARACTERARRAY(placestring, 40)
|
|---|
| 646 | CALL PUSHINTEGER4(label)
|
|---|
| 647 | GOTO 400
|
|---|
| 648 | 500 CONTINUE
|
|---|
| 649 | C FOR DEBUG OF DEBUG ONLY:
|
|---|
| 650 | c CALL LOOKINTEGER4(label)
|
|---|
| 651 | c IF (label.eq.3) GOTO 600
|
|---|
| 652 | c call LOOKCHARACTERARRAY(placestring, 40)
|
|---|
| 653 | c if (label.eq.-2) then
|
|---|
| 654 | c write (*,*) 'untraced call ',placestring
|
|---|
| 655 | c else if (label.eq.2) then
|
|---|
| 656 | c write (*,*) 'TRACED call ',placestring
|
|---|
| 657 | c else if (label.eq.-1) then
|
|---|
| 658 | c write (*,*) 'untraced place ',placestring
|
|---|
| 659 | c else if (label.eq.1) then
|
|---|
| 660 | c write (*,*) 'TRACED place ',placestring
|
|---|
| 661 | c else if (label.eq.0) then
|
|---|
| 662 | c call LOOKREAL8(bigsum)
|
|---|
| 663 | c write (*,*) 'TRACED place ',placestring, bigsum
|
|---|
| 664 | c endif
|
|---|
| 665 | c GOTO 500
|
|---|
| 666 | C end FOR DEBUG OF DEBUG ONLY.
|
|---|
| 667 | 600 CONTINUE
|
|---|
| 668 | END
|
|---|
| 669 |
|
|---|
| 670 | SUBROUTINE DEBUG_FWD_CONCLUDE()
|
|---|
| 671 | IMPLICIT NONE
|
|---|
| 672 | INCLUDE 'debugAD.inc'
|
|---|
| 673 | write (*,'("End of ADJ test.",i2,
|
|---|
| 674 | + " error(s) found. WARNING: testing alters derivatives!")')
|
|---|
| 675 | + dbad_nberrors
|
|---|
| 676 | write (*,
|
|---|
| 677 | +'("===========================================================")')
|
|---|
| 678 | END
|
|---|
| 679 |
|
|---|
| 680 | SUBROUTINE DEBUG_FWD_CALL(unitname)
|
|---|
| 681 | IMPLICIT NONE
|
|---|
| 682 | CHARACTER unitname*(*)
|
|---|
| 683 | INCLUDE 'debugAD.inc'
|
|---|
| 684 | INTEGER label
|
|---|
| 685 | CHARACTER*40 refcallstring, herecallstring
|
|---|
| 686 | label = 999
|
|---|
| 687 | IF (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex)) THEN
|
|---|
| 688 | call POPINTEGER4(label)
|
|---|
| 689 | IF (label.ne.2 .AND. label.ne.-2) THEN
|
|---|
| 690 | write(*,*) 'Control mismatch: FWD call ',
|
|---|
| 691 | + unitname,'; BWD ',label
|
|---|
| 692 | STOP
|
|---|
| 693 | ENDIF
|
|---|
| 694 | call POPCHARACTERARRAY(refcallstring, 40)
|
|---|
| 695 | write (herecallstring,'(a40)') unitname
|
|---|
| 696 | IF (refcallstring.NE.herecallstring) THEN
|
|---|
| 697 | write(*,*) 'Control mismatch: FWD call ',
|
|---|
| 698 | + herecallstring,'; BWD call ',refcallstring
|
|---|
| 699 | STOP
|
|---|
| 700 | ENDIF
|
|---|
| 701 | ENDIF
|
|---|
| 702 | dbad_callindex = dbad_callindex+1
|
|---|
| 703 | write (dbad_callnames(dbad_callindex),'(a40)') unitname
|
|---|
| 704 | dbad_calltraced(dbad_callindex) = (label.eq.2)
|
|---|
| 705 | END
|
|---|
| 706 |
|
|---|
| 707 | SUBROUTINE DEBUG_FWD_EXIT()
|
|---|
| 708 | IMPLICIT NONE
|
|---|
| 709 | INCLUDE 'debugAD.inc'
|
|---|
| 710 | dbad_callindex = dbad_callindex-1
|
|---|
| 711 | END
|
|---|
| 712 |
|
|---|
| 713 | LOGICAL FUNCTION DEBUG_FWD_HERE(placename)
|
|---|
| 714 | IMPLICIT NONE
|
|---|
| 715 | CHARACTER placename*(*)
|
|---|
| 716 | INCLUDE 'debugAD.inc'
|
|---|
| 717 | INTEGER label
|
|---|
| 718 | CHARACTER*40 refplacestring, hereplacestring
|
|---|
| 719 | label = 999
|
|---|
| 720 | IF (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex)) THEN
|
|---|
| 721 | call POPINTEGER4(label)
|
|---|
| 722 | IF (label.ne.1 .AND. label.ne.0 .AND. label.ne.-1) THEN
|
|---|
| 723 | write(*,*) 'Control mismatch: FWD place ',
|
|---|
| 724 | + placename,'; BWD ',label
|
|---|
| 725 | STOP
|
|---|
| 726 | ENDIF
|
|---|
| 727 | call POPCHARACTERARRAY(refplacestring, 40)
|
|---|
| 728 | write (hereplacestring,'(a40)') placename
|
|---|
| 729 | IF (refplacestring.NE.hereplacestring) THEN
|
|---|
| 730 | write(*,*) 'Control mismatch: FWD place ',
|
|---|
| 731 | + hereplacestring,'; BWD place ',refplacestring
|
|---|
| 732 | STOP
|
|---|
| 733 | ENDIF
|
|---|
| 734 | DEBUG_FWD_HERE = (label.NE.-1)
|
|---|
| 735 | IF (label.eq.1) THEN
|
|---|
| 736 | call POPREAL8(dbad_nextrefsum)
|
|---|
| 737 | ENDIF
|
|---|
| 738 | ELSE
|
|---|
| 739 | DEBUG_FWD_HERE = .FALSE.
|
|---|
| 740 | ENDIF
|
|---|
| 741 | RETURN
|
|---|
| 742 | END
|
|---|
| 743 |
|
|---|
| 744 | C DEBUG PRIMITIVES FOR THE ADJOINT MODE, BOTH SWEEPS (DOT-PRODUCT METHOD)
|
|---|
| 745 |
|
|---|
| 746 | SUBROUTINE DEBUG_ADJ_SKIP(placename)
|
|---|
| 747 | IMPLICIT NONE
|
|---|
| 748 | CHARACTER placename*(*)
|
|---|
| 749 | INCLUDE 'debugAD.inc'
|
|---|
| 750 | IF (dbad_phase.eq.1) THEN
|
|---|
| 751 | IF (dbad_callindex.eq.0 .OR.
|
|---|
| 752 | + dbad_calltraced(dbad_callindex)) THEN
|
|---|
| 753 | write(dbad_file,'(i3,a40)') -1, placename
|
|---|
| 754 | ENDIF
|
|---|
| 755 | ENDIF
|
|---|
| 756 | END
|
|---|
| 757 |
|
|---|
| 758 | SUBROUTINE DEBUG_ADJ_rwREAL4(vard)
|
|---|
| 759 | IMPLICIT NONE
|
|---|
| 760 | REAL*4 vard
|
|---|
| 761 | INCLUDE 'debugAD.inc'
|
|---|
| 762 | CALL DEBUG_ADJ_INCRCOEFF()
|
|---|
| 763 | dbad_sum = dbad_sum + dbad_coeff*vard
|
|---|
| 764 | vard = dbad_coeff
|
|---|
| 765 | END
|
|---|
| 766 |
|
|---|
| 767 | SUBROUTINE DEBUG_ADJ_rREAL4(vard)
|
|---|
| 768 | IMPLICIT NONE
|
|---|
| 769 | REAL*4 vard
|
|---|
| 770 | INCLUDE 'debugAD.inc'
|
|---|
| 771 | CALL DEBUG_ADJ_INCRCOEFF()
|
|---|
| 772 | dbad_sum = dbad_sum + dbad_coeff*vard
|
|---|
| 773 | END
|
|---|
| 774 |
|
|---|
| 775 | SUBROUTINE DEBUG_ADJ_wREAL4(vard)
|
|---|
| 776 | IMPLICIT NONE
|
|---|
| 777 | REAL*4 vard
|
|---|
| 778 | INCLUDE 'debugAD.inc'
|
|---|
| 779 | CALL DEBUG_ADJ_INCRCOEFF()
|
|---|
| 780 | vard = dbad_coeff
|
|---|
| 781 | END
|
|---|
| 782 |
|
|---|
| 783 | SUBROUTINE DEBUG_ADJ_rwREAL4ARRAY(vard, length)
|
|---|
| 784 | IMPLICIT NONE
|
|---|
| 785 | INTEGER length
|
|---|
| 786 | REAL*4 vard(length)
|
|---|
| 787 | INTEGER i
|
|---|
| 788 | DO i=1,length
|
|---|
| 789 | CALL DEBUG_ADJ_rwREAL4(vard(i))
|
|---|
| 790 | ENDDO
|
|---|
| 791 | END
|
|---|
| 792 |
|
|---|
| 793 | SUBROUTINE DEBUG_ADJ_rREAL4ARRAY(vard, length)
|
|---|
| 794 | IMPLICIT NONE
|
|---|
| 795 | INTEGER length
|
|---|
| 796 | REAL*4 vard(length)
|
|---|
| 797 | INTEGER i
|
|---|
| 798 | DO i=1,length
|
|---|
| 799 | CALL DEBUG_ADJ_rREAL4(vard(i))
|
|---|
| 800 | ENDDO
|
|---|
| 801 | END
|
|---|
| 802 |
|
|---|
| 803 | SUBROUTINE DEBUG_ADJ_wREAL4ARRAY(vard, length)
|
|---|
| 804 | IMPLICIT NONE
|
|---|
| 805 | INTEGER length
|
|---|
| 806 | REAL*4 vard(length)
|
|---|
| 807 | INTEGER i
|
|---|
| 808 | DO i=1,length
|
|---|
| 809 | CALL DEBUG_ADJ_wREAL4(vard(i))
|
|---|
| 810 | ENDDO
|
|---|
| 811 | END
|
|---|
| 812 |
|
|---|
| 813 | SUBROUTINE DEBUG_ADJ_rwREAL8(vard)
|
|---|
| 814 | IMPLICIT NONE
|
|---|
| 815 | REAL*8 vard
|
|---|
| 816 | INCLUDE 'debugAD.inc'
|
|---|
| 817 | CALL DEBUG_ADJ_INCRCOEFF()
|
|---|
| 818 | dbad_sum = dbad_sum + dbad_coeff*vard
|
|---|
| 819 | vard = dbad_coeff
|
|---|
| 820 | END
|
|---|
| 821 |
|
|---|
| 822 | SUBROUTINE DEBUG_ADJ_rREAL8(vard)
|
|---|
| 823 | IMPLICIT NONE
|
|---|
| 824 | REAL*8 vard
|
|---|
| 825 | INCLUDE 'debugAD.inc'
|
|---|
| 826 | CALL DEBUG_ADJ_INCRCOEFF()
|
|---|
| 827 | dbad_sum = dbad_sum + dbad_coeff*vard
|
|---|
| 828 | END
|
|---|
| 829 |
|
|---|
| 830 | SUBROUTINE DEBUG_ADJ_PRINT()
|
|---|
| 831 | IMPLICIT NONE
|
|---|
| 832 | REAL*8 vard
|
|---|
| 833 | INCLUDE 'debugAD.inc'
|
|---|
| 834 | print *, 'dbad sum:',dbad_sum
|
|---|
| 835 | END
|
|---|
| 836 |
|
|---|
| 837 | SUBROUTINE DEBUG_ADJ_wREAL8(vard)
|
|---|
| 838 | IMPLICIT NONE
|
|---|
| 839 | REAL*8 vard
|
|---|
| 840 | INCLUDE 'debugAD.inc'
|
|---|
| 841 | CALL DEBUG_ADJ_INCRCOEFF()
|
|---|
| 842 | vard = dbad_coeff
|
|---|
| 843 | END
|
|---|
| 844 |
|
|---|
| 845 | SUBROUTINE DEBUG_ADJ_rwREAL8ARRAY(vard, length)
|
|---|
| 846 | IMPLICIT NONE
|
|---|
| 847 | INTEGER length
|
|---|
| 848 | REAL*8 vard(length)
|
|---|
| 849 | INTEGER i
|
|---|
| 850 | DO i=1,length
|
|---|
| 851 | CALL DEBUG_ADJ_rwREAL8(vard(i))
|
|---|
| 852 | ENDDO
|
|---|
| 853 | END
|
|---|
| 854 |
|
|---|
| 855 | SUBROUTINE DEBUG_ADJ_rREAL8ARRAY(vard, length)
|
|---|
| 856 | IMPLICIT NONE
|
|---|
| 857 | INTEGER length
|
|---|
| 858 | REAL*8 vard(length)
|
|---|
| 859 | INTEGER i
|
|---|
| 860 | DO i=1,length
|
|---|
| 861 | CALL DEBUG_ADJ_rREAL8(vard(i))
|
|---|
| 862 | ENDDO
|
|---|
| 863 | END
|
|---|
| 864 |
|
|---|
| 865 | SUBROUTINE DEBUG_ADJ_wREAL8ARRAY(vard, length)
|
|---|
| 866 | IMPLICIT NONE
|
|---|
| 867 | INTEGER length
|
|---|
| 868 | REAL*8 vard(length)
|
|---|
| 869 | INTEGER i
|
|---|
| 870 | DO i=1,length
|
|---|
| 871 | CALL DEBUG_ADJ_wREAL8(vard(i))
|
|---|
| 872 | ENDDO
|
|---|
| 873 | END
|
|---|
| 874 |
|
|---|
| 875 | SUBROUTINE DEBUG_ADJ_rwDISPLAY(placename, deltaindent)
|
|---|
| 876 | IMPLICIT NONE
|
|---|
| 877 | CHARACTER placename*(*)
|
|---|
| 878 | INTEGER deltaindent
|
|---|
| 879 | INCLUDE 'debugAD.inc'
|
|---|
| 880 | CALL DEBUG_ADJ_rDISPLAY(placename, deltaindent)
|
|---|
| 881 | IF (dbad_phase.eq.2) THEN
|
|---|
| 882 | dbad_refsum = dbad_nextrefsum
|
|---|
| 883 | ENDIF
|
|---|
| 884 | END
|
|---|
| 885 |
|
|---|
| 886 | SUBROUTINE DEBUG_ADJ_INCRCOEFF()
|
|---|
| 887 | IMPLICIT NONE
|
|---|
| 888 | INCLUDE 'debugAD.inc'
|
|---|
| 889 | dbad_coeff = dbad_coeff + dbad_seed
|
|---|
| 890 | IF (dbad_coeff.ge.2.d0) dbad_coeff = dbad_coeff - 1.d0
|
|---|
| 891 | END
|
|---|
| 892 |
|
|---|
| 893 | SUBROUTINE DEBUG_ADJ_rDISPLAY(placename, deltaindent)
|
|---|
| 894 | IMPLICIT NONE
|
|---|
| 895 | CHARACTER placename*(*)
|
|---|
| 896 | INTEGER deltaindent
|
|---|
| 897 | INCLUDE 'debugAD.inc'
|
|---|
| 898 | REAL diffpercent
|
|---|
| 899 | IF (dbad_phase.eq.1) THEN
|
|---|
| 900 | write(dbad_file,'(i3,a40)') 1, placename
|
|---|
| 901 | write(dbad_file,*) dbad_sum
|
|---|
| 902 | ELSE
|
|---|
| 903 | if (abs(dbad_refsum).le.dbad_epszero
|
|---|
| 904 | + .and.abs(dbad_sum).le.dbad_epszero) then
|
|---|
| 905 | diffpercent = 0.0
|
|---|
| 906 | else
|
|---|
| 907 | diffpercent = abs(dbad_refsum-dbad_sum)*100.0
|
|---|
| 908 | + /max(abs(dbad_refsum),abs(dbad_sum))
|
|---|
| 909 | endif
|
|---|
| 910 | if (diffpercent.le.dbad_errormax) then
|
|---|
| 911 | c write (*,'(" ok (",
|
|---|
| 912 | c + f4.1,"% ) fwd:",e23.16," bwd:",e23.16)')
|
|---|
| 913 | c + diffpercent,dbad_sum,dbad_refsum
|
|---|
| 914 | else
|
|---|
| 915 | dbad_nberrors = dbad_nberrors+1
|
|---|
| 916 | write (*,'(" ", f5.1,
|
|---|
| 917 | + "% DIFFERENCE!! fwd:",e23.16," bwd:",e23.16)')
|
|---|
| 918 | + diffpercent,dbad_sum,dbad_refsum
|
|---|
| 919 | endif
|
|---|
| 920 | IF (deltaindent.eq.0) THEN
|
|---|
| 921 | CALL DEBUG_DISPLAY_LOCATION(placename)
|
|---|
| 922 | ENDIF
|
|---|
| 923 | ENDIF
|
|---|
| 924 | dbad_sum = 0.d0
|
|---|
| 925 | dbad_coeff = 1.d0
|
|---|
| 926 | END
|
|---|
| 927 |
|
|---|
| 928 | SUBROUTINE DEBUG_ADJ_wDISPLAY(placename, deltaindent)
|
|---|
| 929 | IMPLICIT NONE
|
|---|
| 930 | CHARACTER placename*(*)
|
|---|
| 931 | INTEGER deltaindent
|
|---|
| 932 | INCLUDE 'debugAD.inc'
|
|---|
| 933 | IF (dbad_phase.eq.1) THEN
|
|---|
| 934 | write(dbad_file,'(i3,a40)') 0, placename
|
|---|
| 935 | ELSE
|
|---|
| 936 | IF (deltaindent.eq.0) THEN
|
|---|
| 937 | CALL DEBUG_DISPLAY_LOCATION(placename)
|
|---|
| 938 | ENDIF
|
|---|
| 939 | dbad_refsum = dbad_nextrefsum
|
|---|
| 940 | ENDIF
|
|---|
| 941 | dbad_sum = 0.d0
|
|---|
| 942 | dbad_coeff = 1.d0
|
|---|
| 943 | END
|
|---|
| 944 |
|
|---|
| 945 | SUBROUTINE DEBUG_DISPLAY_LOCATION(placename)
|
|---|
| 946 | IMPLICIT NONE
|
|---|
| 947 | CHARACTER placename*(*)
|
|---|
| 948 | INCLUDE 'debugAD.inc'
|
|---|
| 949 | CHARACTER whites*(50),enclosproc*(40)
|
|---|
| 950 | whites = ' '
|
|---|
| 951 | if (dbad_callindex.EQ.0) then
|
|---|
| 952 | enclosproc = 'Top level'
|
|---|
| 953 | else
|
|---|
| 954 | enclosproc = dbad_callnames(dbad_callindex)
|
|---|
| 955 | endif
|
|---|
| 956 | write(*,*) whites(:2*(dbad_callindex-1)),
|
|---|
| 957 | + ' AT:',placename,' OF ',enclosproc
|
|---|
| 958 | END
|
|---|
