subroutine aptsudp (achars, acell, kperm, npermit, nerr)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSUDP
c
c call aptsudp (achars, acell, kperm, npermit, nerr)
c
c Version: aptsudp Updated 2006 March 7 15:00.
c aptsudp Originated 2006 March 6 16:20.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: In a 9 x 9 Sudoku puzzle, to find which and how many characters
c are permitted in each cell not yet assigned a character.
c
c Input: icell.
c
c Output: kperm, nermit, nerr.
c
c Calls: aptsudp
c
c Glossary:
c
c acell Input Character acell(nrow,ncol), if not achars(0), is
c assigned to row nrow, column ncol of 9 x 9 Sudoku
c grid.
c
c achars Input Set of 10 characters used to fill Sudoku grid.
c A blank or unasssigned cell has acell = achars(0).
c
c nerr Output Error flag. No error if zero.
c 1 if any acell is not a character from achars(0) to
c achars(9).
c 2 if npermit(nrow,ncol) is zero for any cell not yet
c assigned a character.
c
c kperm Output Array kperm(nrow,ncol,idigs). For the cell in row
c nrow, col ncol, with idigs from 1 to 9:
c 0 if character achars(idigs) is not permitted.
c 1 if character achars(idigs) is permitted, but
c not yet assigned.
c 2 if character achars(idigs) is already assigned
c to the cell.
c
c npermit Output Array npermit(nrow,ncol). The total number of
c characters permitted in the cell in row nrow, ncol,
c if the cell has not been assigned a character from
c achars(1) to achars(9).
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc########
ccend.
implicit none
c.... Arguments.
integer kperm(9,9,9) ! Status of row, col, character (0,1,2).
integer nerr ! Error flag, 0, 1 or 2.
integer npermit(9,9) ! # of characters permitted in empty cell.
character*1 achars(0:9) ! Characters used fill Sudoku grid.
character*1 acell(9,9) ! Character assigned to a cell.
c.... Local variables.
integer icell(9,9) ! Index of character assiged to a cell.
integer idigs ! Index of character assigned to a cell.
integer ncol ! Column index, 1 to 9.
integer nrow ! Row index, 1 to 9.
c===============================================================================
cbugc***DEBUG begins.
cbug 9001 format (/ 'aptsudp finding permissions for a Sudoku puzzle.' //
cbug & 'Initially assigned characters are:' //
cbug & ' |-------|-------|-------|' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',23('-'),'|' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',23('-'),'|' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3i2,' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |-------|-------|-------|' )
cbug write ( 3, 9001) ((acell(nrow,ncol), ncol = 1, 9),
cbug & nrow = 1, 9)
cbugc***DEBUG ends.
c.... Initialize statuses, as if no characters have been assigned.
do nrow = 1, 9 ! Loop over rows.
do ncol = 1, 9 ! Loop over columns.
do idigs = 1, 9 ! Loop over characters
kperm(nrow,ncol,idigs) = 1
enddo ! End of loop over characters.
npermit(nrow,ncol) = 9
enddo ! End of loop over columns.
enddo ! End of loop over rows.
c.... Find the indices in achars of each assigned cell character.
do nrow = 1, 9 ! Koop over rows.
do 120 ncol = 1, 9 ! Loop over columns.
do idigs = 0, 9 ! Loop over characters.
if (acell(nrow,ncol) .eq. achars(idigs)) then
icell(nrow,ncol) = idigs
go to 120
endif
enddo ! End of loop over characters.
nerr = 1 ! Not a valid character.
go to 210
120 continue ! End of loop over columns.
enddo ! End of loop over rows.
c.... Find the possiblity of each character in each cell.
c.... Any assigned character is not permitted in the same row, column or box
c.... as the cell to which it is assigned.
do nrow = 1, 9 ! Loop over rows.
do ncol = 1, 9 ! Loop over columns.
if (acell(nrow,ncol) .ne. achars(0)) then
call aptsudx (icell(nrow,ncol), nrow, ncol,
& kperm, npermit, nerr)
endif ! Found a cell with an assigned character.
enddo ! End of loop over columns.
enddo ! End of loop over rows.
c===============================================================================
210 continue
cbugc***DEBUG begins.
cbug
cbug 9010 format (/ 'Number of permitted characters:' /
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, 9010) ((npermit(nrow,ncol), ncol = 1, 9),
cbug & nrow = 1, 9)
cbug
cbug 9012 format (/ 'Permitted characters:')
cbug 9014 format ('|=',3('========'),'=',3('========'),'=',
cbug & 3('========'),'|')
cbug 9016 format ('||',3('-------|'),'|',3('-------|'),'|',
cbug & 3('-------|'),'|')
cbug 9018 format ('|',3('|',3i2,1x),'|',3('|',3i2,1x),'|',
cbug & 3('|',3i2,1x),'||')
cbug
cbug write ( 3, 9012)
cbug write ( 3, 9014)
cbug
cbug do nrow = 1, 3 ! Loop over rows.
cbug write ( 3, 9016)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 1, 3),
cbug & ncol = 1,9)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 4, 6),
cbug & ncol = 1,9)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 7, 9),
cbug & ncol = 1,9)
cbug
cbug enddo ! End of loop over rows.
cbug
cbug write ( 3, 9016)
cbug
cbug write ( 3, 9014)
cbug
cbug do nrow = 4, 6 ! Loop over rows.
cbug write ( 3, 9016)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 1, 3),
cbug & ncol = 1,9)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 4, 6),
cbug & ncol = 1,9)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 7, 9),
cbug & ncol = 1,9)
cbug
cbug enddo ! End of loop over rows.
cbug
cbug write ( 3, 9016)
cbug
cbug write ( 3, 9014)
cbug
cbug do nrow = 7, 9 ! Loop over rows.
cbug write ( 3, 9016)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 1, 3),
cbug & ncol = 1,9)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 4, 6),
cbug & ncol = 1,9)
cbug write ( 3, 9018) ((kperm(nrow,ncol,idigs), idigs = 7, 9),
cbug & ncol = 1,9)
cbug
cbug enddo ! End of loop over rows.
cbug
cbug write ( 3, 9016)
cbug write ( 3, 9014)
cbugc***DEBUG ends.
return
c.... End of subroutine aptsudp. (+1 line.)
end
UCRL-WEB-209832