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