subroutine aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTSUDX
c
c     call aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)
c
c     Version:  aptsudx  Updated    2006 February 10 16:00.
c               aptsudx  Originated 2006 January 24 14:00.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  In a Sudoku puzzle, to not permit the character with index idigs
c               in each cell in the same row, column and box as a cell newly
c               assigned that character.
c
c     Input:    idigs, nrow, ncol, kperm, npermit.
c
c     Output:   kperm, npermit, nerr
c
c     Glossary:
c
c     idigs     Input    Index (1 to 9) of the character newly assigned to the
c                          cell located at column ncol (1 to 9) and row nrow
c                          (1 to 9) of a 9 by 9 Sudoku matrix.
c
c     kperm     Input    Array kperm(nr,nc,idig) is the status of the character
c                          with index idig (0 to 9)in the cell at row nr,
c                          col nc, before that character is assigned to the cellc                          at row nrow, column ncol.
c                          0 if the character with index idig is not permitted,
c                          1 if the character with index idig is permitted, but
c                            not yet assigned.
c                          2 if the character with index idig is assigned to
c                            the cell.
c
c     kperm     Output   Array kperm(nr,nc,idig) after the character with
c                          index idigs is assigned to the cell at row nrow,
c                          column ncol.
c
c     npermit    I/O     Number of characters permitted in an unassigned cell.
c
c     nerr      Output   Error flag.  No error if zero.
c                          1 if idigs is not from 1 to 9.
c                          2 if nrow is not from 1 to 9.
c                          3 if ncol is not from 1 to 9.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc########
ccend.

      implicit none

c.... Arguments.

      integer idigs                   ! Index of char in the cell at nrow, ncol.
      integer idig                    ! Index of char with status assigned.
      integer kperm(9,9,9)            ! Status of row, column, character.
      integer npermit(9,9)            ! # of char permitted in unassigned cell.
      integer ncol                    ! Column index.
      integer nerr                    ! Error flag (0 to 6).
      integer nrow                    ! Row index.

c.... Local variables.

      integer nc                      ! Column index.
      integer ncolbeg                 ! Beginning col index.
      integer ncolend                 ! Ending col index.
      integer nr                      ! Row index.
      integer nrowbeg                 ! Beginning row index.
      integer nrowend                 ! Ending row index.

cbugc***DEBUG begins.
cbug 9001 format (/ 'aptsudx updating status array for a Sudoky puzzle.' /
cbug     &  '  idigs   =',i2 /
cbug     &  '  nrow    =',i2,'  ncol    =',i2 )
cbug 9002 format (/ '  Digits permitted.' //
cbug     &  ' |'23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' // )
cbug 9003 format (/ '  Digit ',i1,'.' //
cbug     &  ' |'23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' // )
cbug      write ( 3, 9001) idigs, nrow, ncol
cbug      write ( 3, 9002) ((npermit(nr,nc), nc = 1, 9), nr = 1, 9)
cbug      do idig = 1, 9
cbug        write ( 3, 9003) idig, ((kperm(nr,nc,idig), nc = 1, 9),
cbug     &                                              nr = 1, 9)
cbug      enddo
cbugc***DEBUG ends.

c.... Test for errors.

      nerr = 0

      if ((idigs .lt. 0) .or. (idigs .gt. 9)) then
        nerr = 1
        go to 210
      endif

      if ((nrow .lt. 0) .or. (nrow .gt. 9)) then
        nerr = 2
        go to 210
      endif

      if ((ncol .lt. 0) .or. (ncol .gt. 9)) then
        nerr = 3
        go to 210
      endif

c.... Change status of assigned digit to 2 in the assigned cell.
cbugcbugc***DEBUG begins.
cbugcbug 9005 format ('Make 2:  kperm(',i2,',',i2,',',i2,') = ',i2)
cbugcbug      write ( 3, 9005) nrow, ncol, idigs, kperm(nrow,ncol,idigs)
cbugcbugc***DEBUG ends.
      kperm(nrow,ncol,idigs) = 2

c.... Change status of all other digits to zero in the assigned cell.

      npermit(nrow,ncol) = 0

      do idig = 1, 9
        if (kperm(nrow,ncol,idig) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug 9004 format ('Make 0:  kperm(',i2,',',i2,',',i2,') = ',i2)
cbugcbug      write ( 3, 9004) nrow, ncol, idig, kperm(nrow,ncol,idig)
cbugcbugc***DEBUG ends.
          kperm(nrow,ncol,idig) = 0
        endif
      enddo

c.... Change status of digit idigs from 1 to 0 in the same row.

      do nc = 1, 9                ! Loop over columns.
        if (kperm(nrow,nc,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug      write ( 3, 9004) nrow, nc, idigs, kperm(nrow,nc,idigs)
cbugcbugc***DEBUG ends.
          kperm(nrow,nc,idigs) = 0
          npermit(nrow,nc)      = npermit(nrow,nc) - 1
        endif
      enddo                       ! End of loop over columns.

c.... Change status of digit idigs from 1 to 0 in the same column.

      do nr = 1, 9                  ! Loop over rows.
        if (kperm(nr,ncol,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug      write ( 3, 9004) nr, ncol, idigs, kperm(nr,ncol,idigs)
cbugcbugc***DEBUG ends.
          kperm(nr,ncol,idigs) = 0
          npermit(nr,ncol)      = npermit(nr,ncol) - 1
        endif
      enddo                         ! End of loop over rows.

c.... Change status of digit idigs from 1 to 0 in the same box.

      nrowbeg = 1 + 3 * ((nrow - 1) / 3)
      nrowend = 3 + 3 * ((nrow - 1) / 3)
      ncolbeg = 1 + 3 * ((ncol - 1) / 3)
      ncolend = 3 + 3 * ((ncol - 1) / 3)

      do nr = nrowbeg, nrowend      ! Loop over rows.
        do nc = ncolbeg, ncolend    ! Loop over columns.
          if (kperm(nr,nc,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug      write ( 3, 9004) nr, nc, idigs, kperm(nr,nc,idigs)
cbugcbugc***DEBUG ends.
            kperm(nr,nc,idigs) = 0
            npermit(nr,nc)      = npermit(nr,nc) - 1
          endif
        enddo                       ! End of loop over columns.
      enddo                         ! End of loop over rows.

  210 continue
cbugc***DEBUG begins.
cbug 9006 format (/ 'aptsudx updated status array for a Sudoku puzzle.',
cbug     &  '  nerr =',i2 )
cbug 9007 format (//
cbug     &  '  Digit ',i1,'.' //
cbug     &  ' |'23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',3i2,' |',3i2,' |',3i2,' |' /
cbug     &  ' |',23('-'),'|' // )
cbug
cbug      write ( 3, 9006) nerr
cbug      write ( 3, 9002) ((npermit(nr,nc), nc = 1, 9), nr = 1, 9)
cbug      do idig = 1, 9
cbug        write ( 3, 9007) idig,
cbug     &    ((kperm(nr,nc,idig), nc = 1, 9), nr = 1, 9)
cbug      enddo
cbugc***DEBUG ends.

      return

      end

UCRL-WEB-209832