c      debb package 
c      Copyright_OML 1999 M. Ishiguro 
c       The source code of this subroutine package
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Appropriate reference must be made at times of publishing 
c       results obtained using this subroutine. 
#define BUGLOG 91
#define BUGMAP 92
      subroutine bug ( Lidy , J , J1 , J2 , Cidt , Iid , Rid , Message )
       implicit real * 8 (a-h,o-z)    
#ifdef MPI 
       include (mpif.h)
#endif 
       common /cmbug/ mess0 , intrct , lc  
       character*(*)  Cidt 
       character*8  cidx , cid  
       character*1  ans ,  clet  
       character*30 version     
       character*80 cbuf , cbugx     
       character*8   clook ,       cletitgo  
       character*8   cmessage ,    clevel   ,  cback    
       character*8   cdummy   ,    cskip   
       character*4  chbug (2), chcom (2), chmap (2), 
     * chdeb (2), chrem (2), choice (2)
       character*4  cb , cc , cm , cd , cr , ch
       character*8  mark8 (2)
       character*10 mark10 (2)
       character*38 mark38 (2) 
       data clook    /'LOOK    '/ , cletitgo /'LETITGO '/ 
       data cmessage /'MESSAGE '/,  clevel   /'LEVEL   '/ , 
     *      cback    /'BACK    '/
       data cdummy   /'DUMMY   '/ , cskip    /'SKIP    '/
       data chbug /'BUG:','bug:'/, chcom /'COM:','com:'/, 
     * chmap /'MAP:','map:'/ 
       data chdeb  /'DEB:','deb:'/, chrem /'MEM:','mem:'/
       data choice /'DEBB','debb'/  
       data iam /1/ 
       data level /0/, map / - 1/ 
       data init /1/ 
       data mark8 / '!!!!!!!!' , 'xxxxxxxx' /    
       data mark10 /'!!!!!!!!!!','xxxxxxxxxx'/   
       data mark38 /'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!', 
     *              'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'/  
       data letitgo /3/, clet /':'/, myid /0/, ndummy /0/, nskip /0/  
c      ................................................................
c      history 
c      version / date           location / memo 
c      proto-1 / 1995.11.26      
c              / 1995.12.6       / level dependent bug!
c      proto-2 / 1995.12.6 
c              / 1995.12.?       / MPI handling 
c      2-MPI   / 1996.1           ISMLIB / 
c              / 1996.4.14               / pre-processing by cpp  
c      3-MPI   / 1998.8.2  bugp ,  bugr ,  bugi routines are added 
c              / 1998.11          implimentation of debug 
c              / 1998.12          implimentation of SKIP / DUMMY command 
c              / 1998.12          extension of LETITGO commnd 
c      proto-3 / 1998.12          lazydog: /  open to isac 
c              / 1998.12.3        level 0 function 
c      4-MPI   / 1999.4.22
c              / 1999.11.2        nowquit 
       version = 'DEBugging Bug, version 4-MPI'
c      bug 
c      Copyright_OML 1999 M. Ishiguro 
c       The source code of this subroutine, as a part of the debb package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Appropriate reference must be made at times of publishing 
c       results obtained using this subroutine. 
       cb = chbug ( iam )
       cc = chcom ( iam )
       cm = chmap ( iam )
       cd = chdeb ( iam )
       cr = chrem ( iam )
       ch = choice ( iam )
       lidt  =  Lidy 
       nowquit = 0
       if( lidt .lt. 0) then 
          call debug ( Cidt , 'set' , ie )
          goto 99 
       end if 
       if( level .lt. lidt ) goto 99 
       if( J .lt. J1 .or. J .gt. j2) goto 99 
       if( init .eq. 1) then 

          level  =  1 
          lidt  =  1 
          init  =  0 
          intrct = 0 
#ifdef OLD
          mess0 =  0 
#else
          mess0 =  1 
#endif
#ifdef    MPI 
          call mpi_comm_rank (MPI_COMM_WORLD , myid , IERR)
#endif 
          if( myid .eq. 0) then 
             write(6,*) version , iam  
             write(6,*)        
             write(6,*) Cidt,': Bug ? (<Y>es / with <M>ap / <N>o bug )'
             read(5 , '(A)') ans 
             if( ans .eq. 'Y' .or. ans .eq. 'y') map  =  0 
             if( ans .eq. 'M' .or. ans .eq. 'm') map  =  1 
             if( ans .eq. 'm' .or. ans .eq. 'y') intrct = 1 
             if( map .ge. 0) then 
                if( map .eq. 1) then 
                   write(6 , '(1x,A,'' started with a Map'')') ch 
               else 
                  write(6 , '(1x,A,'' started'')') ch 
                  write(6 , '(1x,A, I2 , 1H: , A8)') 
     *                    cc , 0 , clook  
                  write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cc , 0 , cletitgo ,  - 10  
                  write(6,'('' MEM: 0:bug.map command list'')')
                  write(6,'('' MEM: 0:'',6(1X , A))') clook , 
     *            cletitgo , cmessage , clevel ,  cback ,  'QUIT'  
                  write(6,'('' MEM: 0:'',6(1X , A))') cskip ,  cdummy 
               end if 
            else 
               write(6,'(1x,A,'' nullified at '',A,''.'')') Cidt , ch 
            end if 
         end if 

#ifdef MPI 
         call mpi_bcast ( map , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD ,
     *   IERR)
         call mpi_bcast ( intrct , 1 , MPI_INTEGER , 0 , 
     *   MPI_COMM_WORLD , IERR)
#endif 
         if( map .ge. 0) then 
            open (BUGLOG ,  file = 'bug.log')
            if( map .eq. 1) then 
               open (BUGMAP ,  file = 'bug.map')
               level  =  0 
               goto 1732 
            end if 
         else 
#ifdef OLD
            level  =  0 
#else
            level  =  0 
            mess0 = 0 
#endif
         end if 
         if( level .le. 0) goto 99 
 1732    lc = 0 
#ifdef OLD
         mess0 = 0 
#else
         mess0 = 1 
#endif
      end if 
      cid  =  Cidt 
      lc =  lc + 1 
 1733 continue 
      lid  =  lidt 
      if( lid .gt. map ) then        
            write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,              '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' ,                     '
     *      lc , Iid , Rid    
            write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,                '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' ,                     '
     *      lc , Iid , Rid    
            goto 99 
      end if 
      if( ndummy .gt. 0) then 
            ndummy = ndummy - 1 
            write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,              '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,                ' 
     *      Iid , Rid    
            write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,                '
     *      D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,                '
     *      Iid , Rid  
            goto 99 
      end if 
 
 596  continue 
      if( lid .le. map ) then        
  877    read(BUGMAP , '(A80)' , end = 999) cbuf 
         if( cbuf (1:1).ne. ' ') then 
            cbugx  =  cbuf (1:4)      
            msdos  =  1 
         else 
            msdos  =  0 
            cbugx  =  cbuf (2:5)      
         end if 
 
         if( cbugx .eq. cr ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2)') itx 
               if( itx .eq.  - 1) itx  =  myid 
               if( itx .eq. myid ) write(6 , '(1H  , A80)') cbuf 
               if( itx .eq. myid ) write(BUGLOG , '(A80)') cbuf 
            else 
               read(BUGMAP , '(5X , I2)') itx 
               if( itx .eq.  - 1) itx  =  myid 
               if( itx .eq. myid ) write(6 , '(A80)') cbuf 
               if( itx .eq. myid ) write(BUGLOG , '(A79)') cbuf (1:79)
            end if 

            goto 877 
         end if 
 
         if( cbugx .eq. cc ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2 , 1X , A8 , I8)') itx , cidx , iidx 
            else 
               read(BUGMAP , '(5X , I2 , 1X , A8 , I8)') itx , cidx , iidx 
            end if 
            if( itx .eq.  - 1) itx  =  myid 
            if( itx .ne. myid ) goto 596 
            if( cidx .eq. clook ) then 
               level  =  1 
               write(6 , '(1x,A, I2 , 1H: , A8)') 
     *                    cc , myid , cidx 
               write(BUGLOG , '(A, I2 , 1H: , A8)') 
     *                    cc , myid , cidx 
               goto 596 
            end if 
            if( level .le. 0) goto 596 
            if( cidx (1:4) .eq. 'QUIT') then 
               write(6 , '(1x,A, I2 , 1H: , A8)') cc , myid , cidx 
               write(BUGLOG , '(A, I2 , 1H: , A8)') cc , myid , cidx 
               nowquit = 1 
            end if 
            if( cidx .eq. cletitgo ) then 
               letit0  =  letitgo 
               if( iidx .le. 2) then 
                  clet  =  '!'
               else 
                  clet  =  ':'
               end if 
               letitgo = iidx 
               if( letitgo .eq. letit0) goto 596 
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                     cc , myid , cidx , letitgo 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                     cc , myid , cidx , letitgo 
               goto 596 
            end if 
            if( cidx .eq. cskip ) then  
               nskip  =  nskip + iidx 
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               goto 596 
            end if 
            if( cidx .eq. cdummy ) then  
               ndummy  =  ndummy + iidx - 1 
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cd , myid , cidx , iidx 
               write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,           '
     *         D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,             '
     *         Iid , Rid  
               write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,             '
     *         D40.33,1H:)') cb , myid , lid , cid , ':' , lc ,             '
     *         Iid , Rid   
               goto 99 
            end if 
            if( cidx .eq. cmessage ) then 
               if( mess0 .eq. iidx ) goto 596 
               mess0 =  iidx        
               write(6 , '(1x,A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cc , myid , cidx , iidx 
               write(BUGLOG , '(A, I2 , 1H: , A8 , I8 , 1H:)') 
     *                    cc , myid , cidx , iidx 
               goto 596 
            end if 
            if( cidx .eq. clevel ) then 
               if( map .gt. iidx .or. level .eq. iidx ) then 
                  write(6,'(1x,A,''level change ignored.'')') cd 
                  goto 596 
               end if 
               level  =  iidx 
               cbugx  =  'MAPLINE'
            end if 
            if( cidx .eq. cback ) then 
               if( level .le. map ) then 
                  write(6,'(1x,A,''level back ignored.'')') cd 
                  goto 596 
               end if 
               level  =  map 
               cbugx  =  'MAPLINE'
            end if 

         end if 
         if( cbugx .eq. cm ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2 , 1X , I2)') itx , iidx 
            else 
               read(BUGMAP , '(5X , I2 , 1X , I2)') itx , iidx 
            end if 

            if( itx .eq. myid ) then 
               map  =  iidx 
               if( level .eq. iidx ) goto 596 
               level  =  iidx 
               cbugx  =  'MAPLINE'
            end if 
         end if 

         if( cbugx .eq. 'MAPLINE') then 
            write(6,'(1x,A,2(I2,'':''),'':::::::::::::::::::::::::'',        '
     *      '':::::::::::::::::::::::::::::::::::::::'')') cm,myid,level     '
            write(BUGLOG,'(A,2(I2,'':''),'':::::::::::::::::::::::::'',          '
     *      '':::::::::::::::::::::::::::::::::::::::'')') cm,myid,level     ' 
            goto 596 
         end if 

         if( cbugx .eq. cb ) then 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP , '(4X , I2 , 1X , I2)') itx , lidx 
            else 
               read(BUGMAP , '(5X , I2 , 1X , I2)') itx , lidx 
            end if 

            if( lidx .gt. map .or. itx .ne. myid ) goto 877 
            backspace BUGMAP 
            if( msdos .eq. 1) then  
               read(BUGMAP ,'(4X,2(I2,1X),A8,1X,I4,1X,I10 , 1X , D40.33)'
     *                       , err = 9)  itx , lidx , cidx , lcx , 
     *                       iidx , ridx 
            else 
               read(BUGMAP ,'(5X,2(I2,1X),A8,1X,I4,1X,I10 , 1X , D40.33)'
     *                       , err = 9)  itx , lidx , cidx , lcx ,
     *                       iidx , ridx 
            end if 
            if( nskip .gt. 0) then 
               nskip  =  nskip  - 1 
               write(6,'(1x,A,I2,1H:,I2,1H:,A8,1H.,I4,1H:,I10,1H:,         '
     *         D40.33,1H:)') cd , myid , lidx , cidx , lcx , iidx ,        ' 
     *         ridx   
               write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,1H.,I4,1H:,I10,1H:,           '
     *         D40.33,1H:)') cd , myid , lidx , cidx , lcx , iidx ,        '  
     *         ridx 
               goto 877 
            end if 
            call debug ( cidx , 'watch' , ie )
            if( ie .eq. 1) goto 877 
    9       continue 

  597       continue 
            if( level .ge. 1) then 
               write(BUGLOG,'(A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,             '
     *         D40.33,1H:)') cb , myid , lid , cid , clet , lc ,            '
     *         Iid , Rid    
               write(6,'(1x,A,I2,1H:,I2,1H:,A8,A1,I4,1H:,I10,1H:,           '
     *         D40.33,1H:)') cb , myid , lid , cid , clet , lc ,            '
     *         Iid , Rid    
            else 
               goto 999 
            end if 
            if( nowquit .eq. 1) then 
#ifdef MPI 
               call mpi_abort (MPI_COMM_WORLD , ICODE , IERR)
#endif 
               stop 
            end if
            ichk  =  0 
            if( lidx .ne. lid ) then 
                ichk  =  1        
            end if 
            if( cidx .ne. cid ) then 
                ichkcid  =  1         
                ichk  =  1        
            else 
                ichkcid  =  0 
            end if 
 
            if( iidx .ne. Iid ) then 
                ichkiid  =  1 
                ichk  =  1        
            else 
                ichkiid  =  0 
            end if 
            ichkrid  =  0 
            jchkrid  =  0 
            if( ridx .ne. Rid ) then 
               if( ridx .ne. 0.d0) then 
                  ratio  =  ( ridx - Rid ) / ridx 
               else 
                  ratio  =  1.d0  
               end if  
               if( ratio .lt. 0.d0) ratio  =   - ratio 
               if( ratio .gt. 0.d0) then 
                  if( ratio .ge. 10.d0 ** letitgo ) jchkrid  =  1 
                  ichkrid  =  1 
                  ichk  =  1 
               end if 
            end if 
   98       continue 
            if( ichk .gt. 0) then 
                write(6,'(11H mismatch!!,A,6H!!!!!!,A,4H!!!!,A)')
     *          mark8 ( ichkcid + 1 ), mark10 ( ichkiid + 1 ),
     *          mark38 ( ichkrid + 1 )
                write(6,'(5H OLD:,I2,1H:,I2,A1,A8,A1,I4,A1,I10,A1,            '
     *          D40.33,1H:)') myid , lidx ,                                  '
     *          ':', cidx , ':' , lcx , ':', iidx , ':', ridx     
                if( ichkrid .gt. 0) 
     *          write(6 , '(1x,A , I2 ,                                       '
     *          '': ratio = (new_rid-old_rid)/old_rid :'' , D10.3)')          '
     *          cd , myid , ratio 
                write(6 , '(1x,A , I2  ,                                      '
     *          '':                           letitgo :'' , I10)')            '
     *          cd , myid , letitgo 
                iquit = 0 
                if( letitgo .le. 2 .and. ichkcid .gt. 0) iquit = 1 
                if( letitgo .le. 1 .and. ichkiid .gt. 0) iquit = 1 
                if( letitgo .le. 0 .and. jchkrid .gt. 0) iquit = 1 
                if( iquit .eq. 1) then 
                   write(6 , '(1x,A,I2,'':QUIT on the mismatch'',            '
     *             I3)')         cd , myid                                   '
                   write(6,'(1x,A,I2,5H:QUIT)') cc 
                   write(BUGLOG,'(A,I2,5H:QUIT)') cc 
#ifdef             MPI 
                   call mpi_abort (MPI_COMM_WORLD , ICODE , IERR)
#endif 
                   stop 
                end if  
             end if 
             goto 99 
          end if 
          goto 877 
       end if 
  99   continue 
       Message  =  mess0 
       return 
 999   continue 
       if( level .eq. 0)  goto 99 
       write(6 , '(1x,A, I2 , 
     *  '': no record. new recording starts.'')') cd , myid 
       map  =  0 
       goto 1733
      end 

      subroutine sbuggle ( Message )
       implicit real * 8 ( a-h , o-z )
       common /cmbug/ mess0 , intrct , lc  
c      ................................................................
c      history 
c      version             date           location 
c      2 - MPI               1996.1         ISMLIB 
c      version - 0           1998.12 
c      sbuggle 
c      Smuggles message into the program.
       Message  =  mess0 
       return 
      end 

      subroutine debug ( Ckeyx , Cmd , Ie )
       implicit real*8 ( a-h , o-z ) 
#ifdef MPI 
       include (mpif.h)
#endif 
       character*(*) Ckeyx ,  Cmd 
       character*20 cmemory (100)
       character*17 ckey 
       data cmemory /100*'                    '/
       data inisub /0/
       data mem  / 0 / 
c      ................................................................
c      debug 
c      Copyright_OML 1999 M. Ishiguro 
c       The source code of this subroutine, as a part of the debb package,
c       can be obtained from ISMLIB(ftp://ftp.ism.ac.jp/pub/ISMLIB/)
c       of the Institute of Statistical Mathematics without any charge. 
c       On the conditions that terms of the OPEN MARKET LICENCE for software
c       (ftp://ftp.ism.ac.jp/pub/ISMLIB/OML/OML-SW-E-1996) are observed and 
c       that the copyright holder nor the Institute of Statistical Mathematics 
c       take no responsibility on any result from the use, this subroutine 
c       can be used or modified freely. On the condition that this note is 
c       attached as it is, this subroutine can be redistributed.
c       Appropriate reference must be made at times of publishing 
c       results obtained using this subroutine. 
c       Enables bug routine to skip some of bug.map lines.
       myself = 9 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          write(6,*) 'DEbug:started'
       end if 
       goto 9200 
c      ========= 
 9100  continue 
       if( iNFO .ge. myself .and. inisub .eq. 0) then 
          if( myself .ge. 2) inisub = 1 
          write(6,*) 'DEbug:exit'
       end if 
       return 
c      ====== 
 9200  continue 
       ckey = Ckeyx 
       Ie = 0 
       do 1 i = 1 , mem 
          if( cmemory ( i ) .eq. ckey // '###') then 
              Ie  =  1 
              goto 9100 
          end if 
    1  continue 
       if( Cmd (1:3) .ne. 'set') goto 9100 
c      --------------------------------- 
       if( mem .lt. 100) then 
          mem  =  mem + 1 
          ii = mem 
       else 
          write(6,*) 'debug:mem exeeded 100 in' ,  myid 
#ifdef    MPI 
          call mpi_abort ( MPI_COMM_WORLD , icode , ierr )
#endif 
          stop 
       end if 
       cmemory ( ii ) = ckey // '###'
       goto 9100 
      end 

