C PRIMITIVES FOR DEBUGGING THE TANGENT AND ADJOINT CODES GENERATED BY TAPENADE.
C These primitives are called by the code produced by Tapenade when using
C the differentiation command-line options -debugTGT and -debugADJ.

C GLOBAL VARIABLES DEFINED IN debugAD.inc:
C-----------------------------------------
C dbad_mode is 1 when running divided-differences test to validate the tangent mode
C             -1 when running dot-product test to validate the adjoint mode.
C dbad_phase is 1 for the 1st executable that is called for the test
C               2 for the 2nd executable that is called for the test
C           Both tests are run by calling $> exe1 | exe2
C dbad_file is the file that is used to make exe1 communicate towards exe2
C           by default it is std_out (6) in phase 1, and std_in (5) in phase 2.
C           It's not actually parametrable, but one may change this
C           if std_in or std_out are unavailable.
C dbad_ddeps is the epsilon used by divided-differences test ONLY.
C           The test 1st order, not centered.
C           dbad_ddeps is not used in the dot-product test.
C           dbad_ddeps is set by DEBUG_TGT_INIT[1,2], as its 1st argument.
C dbad_epszero is the absolute value under which a derivative is
C           considered to be in fact zero. It is used in both tests
C           to eliminate differences between a zero deriv and an undefined deriv.
C           dbad_epszero is set by DEBUG_TGT_INIT[1,2], as its 2nd argument,
C           and by DEBUG_[F,B]WD_INIT, as its 1st argument.
C dbad_errormax is the percentage of difference above which a "difference"
C           message is issued. In divided-differences test, this is about
C           the comparison of tgt diff wrt divided-differences.
C           In dot-product mode, this is about the comparison between
C           the (sum of the) bwd Jacobian wrt the (sum of the) tgt Jacobian.
C           dbad_errormax is set by DEBUG_TGT_INIT[1,2], as its 3rd argument,
C           and by DEBUG_[F,B]WD_INIT, as its 2nd argument.
C dbad_seed is the increment used to "randomize" the X_d and Y_b used in the
C           dot-product test. X_d and Y_d are filled with values in [1.d0 , 2.d0[,
C           starting with 1.d0 and incremented by steps of dbad_seed.
C           dbad_seed is set by DEBUG_[F,B]WD_INIT, as its 3rd argument.
C dbad_callsz is the max depth of nested calls during execution.
C           It is set by default to 99 in debugAD.inc.
C           It may be changed in debugAD.inc, if needed.
C dbad_callnames is the stack of the procedure names in the current call stack.
C           These names are stored without the _D or _B extension.
C dbad_callcodes is a stack of codes of the current call stack.
C           It is currently not used and may disappear sone day.
C dbad_calltraced is a stack of booleans on the current call stack.
C           "true" means that the current call is being traced.
C           A "false" means not traced, and implies a "false" in all
C           deeper calls. In divided-differences test ONLY, this can be
C           overriden by passing "true" as the 3rd argument of
C           DEBUG_TGT_CALL or DEBUG_TGT_HERE.

      BLOCK DATA DEBUG_AD
      IMPLICIT NONE
      INCLUDE 'debugAD.inc'
      DATA dbad_callindex/0/
      DATA dbad_sum/0.d0/
      DATA dbad_coeff/1.d0/
      DATA dbad_seed/0.137d0/
      END

C DEBUG PRIMITIVES FOR THE TANGENT MODE (DIVIDED-DIFFERENCES METHOD)

      SUBROUTINE DEBUG_TGT_INIT1(epsilon, ezero, errmax)
      IMPLICIT NONE
      REAL*8 epsilon, ezero, errmax
      INCLUDE 'debugAD.inc'
      dbad_mode = 1
      dbad_phase = 1
      dbad_file = 6
      dbad_ddeps = epsilon
      dbad_epszero = ezero
      dbad_errormax = errmax
      end

      SUBROUTINE DEBUG_TGT_INIT2(epsilon, ezero, errmax)
      IMPLICIT NONE
      REAL*8 epsilon, ezero, errmax
      INCLUDE 'debugAD.inc'
      dbad_mode = 1
      dbad_phase = 2
      dbad_file = 5
      dbad_ddeps = epsilon
      dbad_epszero = ezero
      dbad_errormax = errmax
      write (*,'("Starting TGT test, epsilon=",e8.1,
     +     ", zero=",e8.1,", errmax=",f4.1,"%")'),
     +     epsilon,ezero,errmax
      write (*,
     +'("===========================================================")')
      end

      SUBROUTINE DEBUG_TGT_INITREAL4(indep, indepd)
      IMPLICIT NONE
      REAL*4 indep, indepd
      INCLUDE 'debugAD.inc'
      if (dbad_phase.eq.1) then
         indep = indep+dbad_ddeps*indepd
      endif
      end

      SUBROUTINE DEBUG_TGT_INITREAL4ARRAY(indep, indepd, length)
      IMPLICIT NONE
      INTEGER length
      REAL*4 indep(length), indepd(length)
      INCLUDE 'debugAD.inc'
      INTEGER i
      if (dbad_phase.eq.1) then
         do i=1,length
            indep(i) = indep(i)+dbad_ddeps*indepd(i)
         enddo
      endif
      end

      SUBROUTINE DEBUG_TGT_INITREAL8(indep, indepd)
      IMPLICIT NONE
      REAL*8 indep, indepd
      INCLUDE 'debugAD.inc'
      if (dbad_phase.eq.1) then
         indep = indep+dbad_ddeps*indepd
      endif
      end

      SUBROUTINE DEBUG_TGT_INITREAL8ARRAY(indep, indepd, length)
      IMPLICIT NONE
      INTEGER length
      REAL*8 indep(length), indepd(length)
      INCLUDE 'debugAD.inc'
      INTEGER i
      if (dbad_phase.eq.1) then
         do i=1,length
            indep(i) = indep(i)+dbad_ddeps*indepd(i)
         enddo
      endif
      end

      SUBROUTINE DEBUG_TGT_CONCLUDEREAL4(varname, var, vard)
      IMPLICIT NONE
      character varname*(*)
      real*4 var, vard
      INCLUDE 'debugAD.inc'
      REAL*4 ddvar, dd, diff, varwr
      LOGICAL areNaNs
      if (dbad_phase.eq.1) then
         write (dbad_file, '(a)') 'final_result'
         write (dbad_file, *) var
      else
         call DDCHECKVARNAME('final_result')
         call DDPICKTWO4(var, varwr, dbad_file, ddvar, areNaNs)
         if (.not.areNaNs) then
            dd = (ddvar-varwr)/dbad_ddeps
            diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
            write (*,'("Final result",a20,": ",e20.8," (ad)",
     +           f9.5,"% DIFF WITH (dd) ",e20.8)')
     +           varname,vard,diff,dd
         else
            write (*, '(a)') 'Final result has NaNs'
         endif
      endif
      write (*,
     +'("===========================================================")')
      END

      SUBROUTINE DEBUG_TGT_CONCLUDEREAL4ARRAY
     +                           (varname, tvar, tvard, length)
      IMPLICIT NONE
      integer length
      real*4 tvar(length)
      real*4 tvard(length)
      character varname*(*)
      REAL*4 var, vard
      INTEGER i
      var = 0.0
      vard = 0.0
      DO i=1,length
         var = var + tvar(i)
         vard = vard + tvard(i)
      ENDDO
      call DEBUG_TGT_CONCLUDEREAL4(varname, var, vard)
      END

      SUBROUTINE DEBUG_TGT_CONCLUDEREAL8(varname, var, vard)
      IMPLICIT NONE
      character varname*(*)
      real*8 var, vard
      INCLUDE 'debugAD.inc'
      REAL*8 ddvar, dd, diff, varwr
      LOGICAL areNaNs
      if (dbad_phase.eq.1) then
         write (dbad_file, '(a)') 'final_result'
         write (dbad_file, *) var
      else
         call DDCHECKVARNAME('final_result')
         call DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
         if (.not.areNaNs) then
            dd = (ddvar-varwr)/dbad_ddeps
            diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
            write (*,'("Final result",a20,": ",e24.16," (ad)",
     +           f9.5,"% DIFF WITH (dd) ",e24.16)')
     +           varname,vard,diff,dd
         else
            write (*, '(a)') 'Final result has NaNs'
         endif
      endif
      write (*,
     +'("===========================================================")')
      END

      SUBROUTINE DEBUG_TGT_CONCLUDEREAL8ARRAY
     +                           (varname, tvar, tvard, length)
      IMPLICIT NONE
      integer length
      real*8 tvar(length)
      real*8 tvard(length)
      character varname*(*)
      REAL*8 var, vard
      INTEGER i
      var = 0.d0
      vard = 0.d0
      DO i=1,length
         var = var + tvar(i)
         vard = vard + tvard(i)
      ENDDO
      call DEBUG_TGT_CONCLUDEREAL8(varname, var, vard)
      END

      SUBROUTINE DEBUG_TGT_CALL(unitname, traced, forcetraced)
      IMPLICIT NONE
      CHARACTER unitname*(*)
      LOGICAL traced, forcetraced
      INCLUDE 'debugAD.inc'
      dbad_callindex = dbad_callindex+1
      write (dbad_callnames(dbad_callindex),'(a40)') unitname
      dbad_calltraced(dbad_callindex) =
     +     ((dbad_callindex.eq.1.OR.
     +       dbad_calltraced(dbad_callindex-1))
     +     .AND.traced) .OR. forcetraced
      END

      SUBROUTINE DEBUG_TGT_EXIT()
      IMPLICIT NONE
      INCLUDE 'debugAD.inc'
      dbad_callindex = dbad_callindex-1
      END

      LOGICAL FUNCTION DEBUG_TGT_HERE(placename, forcetraced)
      IMPLICIT NONE
      CHARACTER placename*(*)
      LOGICAL forcetraced
      INCLUDE 'debugAD.inc'
      DEBUG_TGT_HERE =
     +     (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex))
     +     .OR.forcetraced
      RETURN
      END

      SUBROUTINE DEBUG_TGT_REAL4(varname, var, vard)
      IMPLICIT NONE
      character varname*(*)
      REAL*4 var, vard
      INCLUDE 'debugAD.inc'
      REAL*4 ddvar, dd, diff, varwr
      LOGICAL areNaNs
      character*12 diffstr
      character*50 ddvarname
      if (dbad_phase.eq.1) then
         WRITE(dbad_file, '(a)') varname
         WRITE(dbad_file, *) var
      else if (dbad_phase.eq.2) then
         call DDCHECKVARNAME(varname)
         call DDPICKTWO4(var, varwr, dbad_file, ddvar, areNaNs)
         if (.not.areNaNs) then
            dd = (ddvar-varwr)/dbad_ddeps
            if ((abs(vard).gt.dbad_epszero)
     +           .or.(abs(dd).gt.dbad_epszero)) then
               diff = (abs(vard-dd)*100.0)/max(abs(vard),abs(dd))
               if (diff.gt.dbad_errormax) then
                  diffstr = 'DIFFERENCE!!'
               else
                  diffstr = '            '
               endif
               write (*,'("   ", a,":",e11.4,
     +              " (dd:",e11.4,")   ",a14)')
     +              varname, vard, dd, diffstr
            endif
         endif
      endif
      END

      SUBROUTINE DEBUG_TGT_REAL4ARRAY (varname, var, vard, length)
      IMPLICIT NONE
      integer length
      real*4 var(length)
      real*4 vard(length)
      character varname*(*)
      INCLUDE 'debugAD.inc'
      real*4 ddvar, dd, diff, varwr
      real*4 valbuf(10),ddbuf(10)
      character*50 ddvarname
      integer indexbuf1(10)
      character*14 diffbuf(10)
      integer i1,j
      integer ibuf
      logical notprintedheader
      LOGICAL areNaNs
      if (dbad_phase.eq.1) then
         WRITE(dbad_file, '(a)') varname
         do i1=1,length
            WRITE(dbad_file, *) var(i1)
         enddo
      else if (dbad_phase.eq.2) then
         call DDCHECKVARNAME(varname)
         notprintedheader=.true.
         ibuf = 1
         do i1=1,length
            call DDPICKTWO4(var(i1),varwr,dbad_file,ddvar,areNaNs)
            if (.not.areNaNs) then
               dd = (ddvar-varwr)/dbad_ddeps
               if ((abs(vard(i1)).gt.dbad_epszero)
     +              .or.(abs(dd).gt.dbad_epszero)) then
                  valbuf(ibuf) = vard(i1)
                  ddbuf(ibuf) = dd
                  indexbuf1(ibuf) = i1
                  diff = (abs(vard(i1)-dd)*100.0)
     +                    /max(abs(vard(i1)),abs(dd))
                  if (diff.gt.dbad_errormax) then
                     diffbuf(ibuf) = '  DIFFERENCE!!'
                     ibuf = ibuf+1
                  else
!                     diffbuf(ibuf) = '              '
!                     ibuf = ibuf+1
                  endif
               endif
            endif
            if(ibuf.gt.10.or.(i1.eq.length.and.ibuf.gt.1)) then
               if (notprintedheader) then
                  write(*,'("   ", a, ":")') varname
                  notprintedheader=.false.
               endif
               write (*, '("          ", 10(i4,"->",e11.4))')
     +              (indexbuf1(j),valbuf(j), j=1,ibuf-1)
               write (*, '("      (dd:)", 10("    (",e11.4,")"))')
     +              (ddbuf(j), j=1,ibuf-1)
               write (*, '("          ", 10(a16))')
     +              (diffbuf(j), j=1,ibuf-1)
               ibuf = 1
            endif
         end do
      endif
      END

      SUBROUTINE DDPICKTWO4(var, varwr, dbad_file, ddvar, areNaNs)
      IMPLICIT NONE
      REAL*4 var,varwr,ddvar
      LOGICAL areNaNs
      INTEGER dbad_file,stat1,stat2
      OPEN(38, FILE='ddwrfile')
      WRITE(38, *) var
      REWIND(38)
      READ(38, *,IOSTAT=stat1) varwr
      CLOSE(38)
      READ(dbad_file, *,IOSTAT=stat2) ddvar
      areNaNs = stat1.eq.225.and.stat2.eq.225
      END

      SUBROUTINE DEBUG_TGT_REAL8(varname, var, vard)
      IMPLICIT NONE
      CHARACTER varname*(*)
      REAL*8 var, vard
      INCLUDE 'debugAD.inc'
      REAL*8 ddvar, dd, diff, varwr
      character*12 diffstr
      character*50 ddvarname
      LOGICAL areNaNs
      if (dbad_phase.eq.1) then
         WRITE(dbad_file, '(a)') varname
         WRITE(dbad_file, *) var
      else if (dbad_phase.eq.2) then
         call DDCHECKVARNAME(varname)
         call DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
         if (.not.areNaNs) then
            dd = (ddvar-varwr)/dbad_ddeps
            if ((abs(vard).gt.dbad_epszero)
     +           .or.(abs(dd).gt.dbad_epszero)) then
               diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
               if (diff.gt.dbad_errormax) then
                  diffstr = 'DIFFERENCE!!'
                  write (*,'(a20,":  ",e24.16," (ad)",
     +                 f5.1,"% DIFF WITH (dd) ",e24.16)')
     +                 varname, vard, diff, dd
               else
                  diffstr = '            '
               endif
!               write (*,*) ddvar,varwr,dd,'=?=',vard,' %',diff,varname
!               write (*,*) varname, vard, 'dd:', dd, diffstr
            endif
         endif
      endif
      END

      SUBROUTINE DEBUG_TGT_REAL8v(varname, var, vard)
      IMPLICIT NONE
      CHARACTER varname*(*)
      REAL*8 var, vard
      INCLUDE 'debugAD.inc'
      REAL*8 ddvar, dd, diff, varwr
      character*12 diffstr
      character*50 ddvarname
      LOGICAL areNaNs
      if (dbad_phase.eq.1) then
         WRITE(dbad_file, '(a)') varname
         WRITE(dbad_file, *) var
      else if (dbad_phase.eq.2) then
         call DDCHECKVARNAME(varname)
         call DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
         if (.not.areNaNs) then
            dd = (ddvar-varwr)/dbad_ddeps
            if ((abs(vard).gt.dbad_epszero)
     +           .or.(abs(dd).gt.dbad_epszero)) then
               diff = (abs(vard-dd)*100.0)/ max(abs(vard),abs(dd))
               if (diff.gt.dbad_errormax) then
                  diffstr = 'DIFFERENCE!!'
                  write (*,'(a20,":  ",e24.16," (ad)",
     +                 f5.1,"% DIFF WITH (dd) ",e24.16)')
     +                 varname, vard, diff, dd
               else
                  diffstr = '            '
               endif
               write (*,*) varname,ddvar,varwr,dd,'=?=',vard,' %',diff
            else
               write (*,*) varname,ddvar,varwr,dd,'=?zero?=',vard
            endif
         endif
      endif
      END

      SUBROUTINE DEBUG_TGT_REAL8ARRAY(varname, var, vard, length)
      IMPLICIT NONE
      integer length
      real*8 var(length)
      real*8 vard(length)
      character varname*(*)
      INCLUDE 'debugAD.inc'
      LOGICAL areNaNs
      real*8 ddvar, dd, diff, varwr
      real*8 valbuf(10),ddbuf(10)
      character*50 ddvarname
      integer indexbuf1(10)
      character*14 diffbuf(10)
      integer i1,j
      integer ibuf
      logical notprintedheader
      if (dbad_phase.eq.1) then
         WRITE(dbad_file, '(a)') varname
         do i1=1,length
            WRITE(dbad_file, *) var(i1)
         enddo
      else if (dbad_phase.eq.2) then
         call DDCHECKVARNAME(varname)
         notprintedheader=.true.
         ibuf = 1
         do i1=1,length
            call DDPICKTWO8(var(i1),varwr,dbad_file,ddvar,areNaNs)
            if (.not.areNaNs) then
               dd = (ddvar-varwr)/dbad_ddeps
               if ((abs(vard(i1)).gt.dbad_epszero)
     +              .or.(abs(dd).gt.dbad_epszero)) then
                  valbuf(ibuf) = vard(i1)
                  ddbuf(ibuf) = dd
                  indexbuf1(ibuf) = i1
                  diff = (abs(vard(i1)-dd)*100.0)
     +                 /max(abs(vard(i1)),abs(dd))
                  if (diff.gt.dbad_errormax) then
                     diffbuf(ibuf) = '  DIFFERENCE!!'
                     ibuf = ibuf+1
                  else
!                     diffbuf(ibuf) = '              '
!                     ibuf = ibuf+1
                  endif
               endif
            endif
            if(ibuf.gt.10.or.(i1.eq.length.and.ibuf.gt.1)) then
               if (notprintedheader) then
                  write(*,'("   ", a, ":")') varname
                  notprintedheader=.false.
               endif
               write (*, '("          ", 10(i4,"->",e11.4))')
     +              (indexbuf1(j),valbuf(j), j=1,ibuf-1)
               write (*, '("      (dd:)", 10("    (",e11.4,")"))')
     +              (ddbuf(j), j=1,ibuf-1)
               write (*, '("          ", 10(a16))')
     +              (diffbuf(j), j=1,ibuf-1)
               ibuf = 1
            endif
         end do
      endif
      END

      SUBROUTINE DDPICKTWO8(var, varwr, dbad_file, ddvar, areNaNs)
      IMPLICIT NONE
      REAL*8 var,varwr,ddvar
      LOGICAL areNaNs
      INTEGER dbad_file,stat1,stat2
      OPEN(38, FILE='ddwrfile')
      WRITE(38, *) var
      REWIND(38)
      READ(38, *,IOSTAT=stat1) varwr
      CLOSE(38)
      READ(dbad_file, *,IOSTAT=stat2) ddvar
      areNaNs = stat1.eq.225.and.stat2.eq.225
      END

      SUBROUTINE DDCHECKVARNAME(varname)
      IMPLICIT NONE
      character varname*(*)
      INCLUDE 'debugAD.inc'
      character*50 ddvarname
      integer linesskip
      linesskip = 0
 100  CONTINUE
      if (linesskip.GT.990000) THEN
         write(*,*)
     +    'ERROR: Too many lines skipped. Bad DD program control ?'
         write(*,*) 'Was looking for variable:',varname
         STOP
      ENDIF
      READ(dbad_file, '(a)') ddvarname
      if (ddvarname.ne.varname) then
!         write(*,*) 'ERROR: mismatch in DD program control !!!',
!     +        ' read ', ddvarname, ' expecting ', varname
         linesskip = linesskip+1
         GOTO 100
      endif
      END

      SUBROUTINE DEBUG_TGT_DISPLAY(placename)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INCLUDE 'debugAD.inc'
      if (dbad_phase.eq.2) then
         CALL DEBUG_DISPLAY_LOCATION(placename)
      endif
      END

C DEBUG PRIMITIVES FOR THE ADJOINT MODE, BACKWARD SWEEP (DOT-PRODUCT METHOD)

      SUBROUTINE DEBUG_BWD_INIT(ezero, errmax, seed)
      IMPLICIT NONE
      REAL*8 ezero, errmax, seed
      INCLUDE 'debugAD.inc'
      dbad_mode = -1
      dbad_phase = 1
      dbad_file = 6
      dbad_epszero = ezero
      dbad_errormax = errmax
      dbad_seed = seed
      write(dbad_file,'(i3,a40)') 3, 'StartOfPhase1'
      END

      SUBROUTINE DEBUG_BWD_CONCLUDE()
      IMPLICIT NONE
      INCLUDE 'debugAD.inc'
      REAL*8 sumd
      INTEGER*4 smallsize, nbblocks, SMALLSTACKSIZE
      INTEGER*4 nbreals, i
      write(dbad_file,'(i3,a40)') -3, 'EndOfPhase1'
      END

      SUBROUTINE DEBUG_BWD_CALL(unitname, traced)
      IMPLICIT NONE
      CHARACTER unitname*(*)
      LOGICAL traced
      INCLUDE 'debugAD.inc'
      dbad_callindex = dbad_callindex+1
      write (dbad_callnames(dbad_callindex),'(a40)') unitname
      dbad_calltraced(dbad_callindex) =
     +     (dbad_callindex.eq.1.OR.
     +       dbad_calltraced(dbad_callindex-1))
     +     .AND.traced
      end

      SUBROUTINE DEBUG_BWD_EXIT()
      IMPLICIT NONE
      INCLUDE 'debugAD.inc'
      IF (dbad_callindex.eq.1 .OR.
     +     dbad_calltraced(dbad_callindex-1)) THEN
         IF (dbad_calltraced(dbad_callindex)) THEN
            write(dbad_file,'(i3,a40)')
     +           2, dbad_callnames(dbad_callindex)
         ELSE
            write(dbad_file,'(i3,a40)')
     +           -2, dbad_callnames(dbad_callindex)
         ENDIF
      ENDIF
      dbad_callindex = dbad_callindex-1
      END

      LOGICAL FUNCTION DEBUG_BWD_HERE(placename)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INCLUDE 'debugAD.inc'
      DEBUG_BWD_HERE =
     +     (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex))
      RETURN
      END

C DEBUG PRIMITIVES FOR THE ADJOINT MODE, FORWARD SWEEP (DOT-PRODUCT METHOD)

      SUBROUTINE DEBUG_FWD_INIT(ezero, errmax, seed)
      IMPLICIT NONE
      REAL*8 ezero, errmax, seed
      INCLUDE 'debugAD.inc'
      INTEGER label
      CHARACTER*40 startstring
      CHARACTER*40 placestring
      REAL*8 bigsum
      dbad_mode = -1
      dbad_phase = 2
      dbad_file = 5
      dbad_epszero = ezero
      dbad_errormax = errmax
      dbad_seed = seed
      dbad_nberrors = 0
      write (*,'("Starting ADJ test, zero=",e8.1,
     +     ", errmax=",f4.1,"%, seed=",f5.3)'),
     +     ezero,errmax,seed
      write (*,
     +'("===========================================================")')
C labels:  3 -> StartOfPhase1
C         -1 -> a debug point, skipped
C          0 -> a debug point, traced but no associated value.
C          1 -> a debug point, traced, with an associated value.
C         -2 -> a call, skipped
C          2 -> a call, traced
C         -3 -> EndOfPhase1
 100  READ(dbad_file,'(i3,a40)',ERR=200,END=500) label,startstring
      if (label.eq.3.AND.
     +     startstring.EQ.'                           StartOfPhase1')
     +     GOTO 300
 200  GOTO 100
 300  CALL PUSHINTEGER4(3)
 400  READ(dbad_file,'(i3,a40)',ERR=500,END=500) label,placestring
      IF (label.eq.-3) GOTO 500
      IF (label.eq.1) THEN
         READ(dbad_file,*) bigsum
         CALL PUSHREAL8(bigsum)
      ENDIF
      CALL PUSHCHARACTERARRAY(placestring, 40)
      CALL PUSHINTEGER4(label)
      GOTO 400
 500  CONTINUE
C FOR DEBUG OF DEBUG ONLY:
c      CALL LOOKINTEGER4(label)
c      IF (label.eq.3) GOTO 600
c      call LOOKCHARACTERARRAY(placestring, 40)
c      if (label.eq.-2) then
c         write (*,*) 'untraced  call ',placestring
c      else if (label.eq.2) then
c         write (*,*) 'TRACED    call ',placestring
c      else if (label.eq.-1) then
c         write (*,*) 'untraced place ',placestring
c      else if (label.eq.1) then
c         write (*,*) 'TRACED   place ',placestring
c      else if (label.eq.0) then
c         call LOOKREAL8(bigsum)
c         write (*,*) 'TRACED   place ',placestring, bigsum
c      endif
c      GOTO 500
C end FOR DEBUG OF DEBUG ONLY.
 600  CONTINUE
      END

      SUBROUTINE DEBUG_FWD_CONCLUDE()
      IMPLICIT NONE
      INCLUDE 'debugAD.inc'
      write (*,'("End of ADJ test.",i2,
     +     " error(s) found. WARNING: testing alters derivatives!")')
     +     dbad_nberrors
      write (*,
     +'("===========================================================")')
      END

      SUBROUTINE DEBUG_FWD_CALL(unitname)
      IMPLICIT NONE
      CHARACTER unitname*(*)
      INCLUDE 'debugAD.inc'
      INTEGER label
      CHARACTER*40 refcallstring, herecallstring
      label = 999
      IF (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex)) THEN
         call POPINTEGER4(label)
         IF (label.ne.2 .AND. label.ne.-2) THEN
            write(*,*) 'Control mismatch: FWD call ',
     +           unitname,'; BWD ',label
            STOP
         ENDIF
         call POPCHARACTERARRAY(refcallstring, 40)
         write (herecallstring,'(a40)') unitname
         IF (refcallstring.NE.herecallstring) THEN
            write(*,*) 'Control mismatch: FWD call ',
     +           herecallstring,'; BWD call ',refcallstring
            STOP
         ENDIF
      ENDIF
      dbad_callindex = dbad_callindex+1
      write (dbad_callnames(dbad_callindex),'(a40)') unitname
      dbad_calltraced(dbad_callindex) = (label.eq.2)
      END

      SUBROUTINE DEBUG_FWD_EXIT()
      IMPLICIT NONE
      INCLUDE 'debugAD.inc'
      dbad_callindex = dbad_callindex-1
      END

      LOGICAL FUNCTION DEBUG_FWD_HERE(placename)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INCLUDE 'debugAD.inc'
      INTEGER label
      CHARACTER*40 refplacestring, hereplacestring
      label = 999
      IF (dbad_callindex.eq.0.OR.dbad_calltraced(dbad_callindex)) THEN
         call POPINTEGER4(label)
         IF (label.ne.1 .AND. label.ne.0 .AND. label.ne.-1) THEN
            write(*,*) 'Control mismatch: FWD place ',
     +           placename,'; BWD ',label
            STOP
         ENDIF
         call POPCHARACTERARRAY(refplacestring, 40)
         write (hereplacestring,'(a40)') placename
         IF (refplacestring.NE.hereplacestring) THEN
            write(*,*) 'Control mismatch: FWD place ',
     +           hereplacestring,'; BWD place ',refplacestring
            STOP
         ENDIF
         DEBUG_FWD_HERE = (label.NE.-1)
         IF (label.eq.1) THEN
            call POPREAL8(dbad_nextrefsum)
         ENDIF
      ELSE
         DEBUG_FWD_HERE = .FALSE.
      ENDIF
      RETURN
      END

C DEBUG PRIMITIVES FOR THE ADJOINT MODE, BOTH SWEEPS (DOT-PRODUCT METHOD)

      SUBROUTINE DEBUG_ADJ_SKIP(placename)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INCLUDE 'debugAD.inc'
      IF (dbad_phase.eq.1) THEN
         IF (dbad_callindex.eq.0 .OR.
     +        dbad_calltraced(dbad_callindex)) THEN
            write(dbad_file,'(i3,a40)') -1, placename
         ENDIF
      ENDIF
      END

      SUBROUTINE DEBUG_ADJ_rwREAL4(vard)
      IMPLICIT NONE
      REAL*4 vard
      INCLUDE 'debugAD.inc'
      CALL DEBUG_ADJ_INCRCOEFF()
      dbad_sum = dbad_sum + dbad_coeff*vard
      vard = dbad_coeff
      END

      SUBROUTINE DEBUG_ADJ_rREAL4(vard)
      IMPLICIT NONE
      REAL*4 vard
      INCLUDE 'debugAD.inc'
      CALL DEBUG_ADJ_INCRCOEFF()
      dbad_sum = dbad_sum + dbad_coeff*vard
      END

      SUBROUTINE DEBUG_ADJ_wREAL4(vard)
      IMPLICIT NONE
      REAL*4 vard
      INCLUDE 'debugAD.inc'
      CALL DEBUG_ADJ_INCRCOEFF()
      vard = dbad_coeff
      END

      SUBROUTINE DEBUG_ADJ_rwREAL4ARRAY(vard, length)
      IMPLICIT NONE
      INTEGER length
      REAL*4 vard(length)
      INTEGER i
      DO i=1,length
         CALL DEBUG_ADJ_rwREAL4(vard(i))
      ENDDO
      END

      SUBROUTINE DEBUG_ADJ_rREAL4ARRAY(vard, length)
      IMPLICIT NONE
      INTEGER length
      REAL*4 vard(length)
      INTEGER i
      DO i=1,length
         CALL DEBUG_ADJ_rREAL4(vard(i))
      ENDDO
      END

      SUBROUTINE DEBUG_ADJ_wREAL4ARRAY(vard, length)
      IMPLICIT NONE
      INTEGER length
      REAL*4 vard(length)
      INTEGER i
      DO i=1,length
         CALL DEBUG_ADJ_wREAL4(vard(i))
      ENDDO
      END

      SUBROUTINE DEBUG_ADJ_rwREAL8(vard)
      IMPLICIT NONE
      REAL*8 vard
      INCLUDE 'debugAD.inc'
      CALL DEBUG_ADJ_INCRCOEFF()
      dbad_sum = dbad_sum + dbad_coeff*vard
      vard = dbad_coeff
      END

      SUBROUTINE DEBUG_ADJ_rREAL8(vard)
      IMPLICIT NONE
      REAL*8 vard
      INCLUDE 'debugAD.inc'
      CALL DEBUG_ADJ_INCRCOEFF()
      dbad_sum = dbad_sum + dbad_coeff*vard
      END

      SUBROUTINE DEBUG_ADJ_PRINT()
      IMPLICIT NONE
      REAL*8 vard
      INCLUDE 'debugAD.inc'
      print *, 'dbad sum:',dbad_sum
      END

      SUBROUTINE DEBUG_ADJ_wREAL8(vard)
      IMPLICIT NONE
      REAL*8 vard
      INCLUDE 'debugAD.inc'
      CALL DEBUG_ADJ_INCRCOEFF()
      vard = dbad_coeff
      END

      SUBROUTINE DEBUG_ADJ_rwREAL8ARRAY(vard, length)
      IMPLICIT NONE
      INTEGER length
      REAL*8 vard(length)
      INTEGER i
      DO i=1,length
         CALL DEBUG_ADJ_rwREAL8(vard(i))
      ENDDO
      END

      SUBROUTINE DEBUG_ADJ_rREAL8ARRAY(vard, length)
      IMPLICIT NONE
      INTEGER length
      REAL*8 vard(length)
      INTEGER i
      DO i=1,length
         CALL DEBUG_ADJ_rREAL8(vard(i))
      ENDDO
      END

      SUBROUTINE DEBUG_ADJ_wREAL8ARRAY(vard, length)
      IMPLICIT NONE
      INTEGER length
      REAL*8 vard(length)
      INTEGER i
      DO i=1,length
         CALL DEBUG_ADJ_wREAL8(vard(i))
      ENDDO
      END

      SUBROUTINE DEBUG_ADJ_rwDISPLAY(placename, deltaindent)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INTEGER deltaindent
      INCLUDE 'debugAD.inc'
      CALL DEBUG_ADJ_rDISPLAY(placename, deltaindent)
      IF (dbad_phase.eq.2) THEN
         dbad_refsum = dbad_nextrefsum
      ENDIF
      END

      SUBROUTINE DEBUG_ADJ_INCRCOEFF()
      IMPLICIT NONE
      INCLUDE 'debugAD.inc'
      dbad_coeff = dbad_coeff + dbad_seed
      IF (dbad_coeff.ge.2.d0) dbad_coeff = dbad_coeff - 1.d0
      END

      SUBROUTINE DEBUG_ADJ_rDISPLAY(placename, deltaindent)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INTEGER deltaindent
      INCLUDE 'debugAD.inc'
      REAL diffpercent
      IF (dbad_phase.eq.1) THEN
         write(dbad_file,'(i3,a40)') 1, placename
         write(dbad_file,*) dbad_sum
      ELSE
         if (abs(dbad_refsum).le.dbad_epszero
     +        .and.abs(dbad_sum).le.dbad_epszero) then
            diffpercent = 0.0
         else
            diffpercent = abs(dbad_refsum-dbad_sum)*100.0
     +           /max(abs(dbad_refsum),abs(dbad_sum))
         endif
         if (diffpercent.le.dbad_errormax) then
c            write (*,'("                                     ok (",
c     +           f4.1,"% )  fwd:",e23.16,"  bwd:",e23.16)')
c     +           diffpercent,dbad_sum,dbad_refsum
         else
            dbad_nberrors = dbad_nberrors+1
            write (*,'("                             ", f5.1,
     +           "% DIFFERENCE!!  fwd:",e23.16,"  bwd:",e23.16)')
     +           diffpercent,dbad_sum,dbad_refsum
         endif
         IF (deltaindent.eq.0) THEN
            CALL DEBUG_DISPLAY_LOCATION(placename)
         ENDIF
      ENDIF
      dbad_sum = 0.d0
      dbad_coeff = 1.d0
      END

      SUBROUTINE DEBUG_ADJ_wDISPLAY(placename, deltaindent)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INTEGER deltaindent
      INCLUDE 'debugAD.inc'
      IF (dbad_phase.eq.1) THEN
         write(dbad_file,'(i3,a40)') 0, placename
      ELSE
         IF (deltaindent.eq.0) THEN
            CALL DEBUG_DISPLAY_LOCATION(placename)
         ENDIF
         dbad_refsum = dbad_nextrefsum
      ENDIF
      dbad_sum = 0.d0
      dbad_coeff = 1.d0
      END

      SUBROUTINE DEBUG_DISPLAY_LOCATION(placename)
      IMPLICIT NONE
      CHARACTER placename*(*)
      INCLUDE 'debugAD.inc'
      CHARACTER whites*(50),enclosproc*(40)
      whites = '                                                  '
      if (dbad_callindex.EQ.0) then
         enclosproc = 'Top level'
      else
         enclosproc = dbad_callnames(dbad_callindex)
      endif
      write(*,*) whites(:2*(dbad_callindex-1)),
     +     ' AT:',placename,' OF ',enclosproc
      END
