subroutine aptsudo (achars, acell, nchars, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSUDO
c
c call aptsudo (achars, acell, nchars, nerr)
c
c Version: aptsudo Updated 2006 February 21 14:40.
c aptsudo Originated 2006 January 23 13:30.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To find the solution to a Sudoku puzzle, consisting of a
c 9 x 9 grid of cells, subdivided into nine 3 x 3 boxes, with
c each cell containing one of the nine unique characters achars(1)
c to achars(9) (achars(0) represents an unassigned or blank cell)
c and with no character appearing more than once in any row,
c column or box, and with the character in 17 or more cells
c initially specified.
c
c Any solution remains a solution if the nine characters from
c achars(1) to achars(9) are replaced with any arbitrary set of
c nine unique symbols, including the characters from 1 o 9, but
c in any other arbitrary order. There are 9! = 362880 ways to
c do this.
c
c Any solution remains a solution if three bands or three
c stacks of boxes are swapped, or if the 3 rows in a band
c of boxes or the three columns in a stack of boxes are
c swapped. There are 6^8 = 1,679,616 ways to do all this.
c
c Any solution remains a solution if the grid is rotated,
c inverted, or reflected. There are 16 ways to do this, but
c all but 2 may be done by the permutations described above. (?)
c
c Any solution may be transformed into another solution by the
c preceding methods in 9! * 6^8 * 2 = 1,218,998,108,160 ways.
c
c For row index NR = 1, 9, column index NC = 1, 9, cell index
c J = 1, 81 and box index NB = 1, 9, the conversions are:
c
c J = NC + 9 * (NR - 1)
c
c NR = 1 + ((J - 1) / 9)
c NC = 1 + mod (J - 1, 9)
c
c NB = 1 + 3 * ((NR - 1) / 3) + (NC - 1) / 3
c NB = 1 + (J - 1) / 3 - 3 * ((J - 1) / 9) + 3 * ((J - 1) / 27)
c
c NR = 1 + 3 * ((NB - 1) / 3) to 3 + 3 * ((NB - 1) / 3)
c NC = 1 + 3 * mod (NB - 1, 3) to 3 + 3 * mod (NB - 1, 3)
c
c Input: achars, acell.
c
c Output: acell, nchars, nerr.
c
c Glossary:
c
c acell Input Array acell(nrow,ncol). If not achars(0), the
c initially assigned character in the cell located at
c row nrow, column ncol of the Sudoku grid.
c At least 17 cells must have an initially assigned
c character. Some sets of initially assigned characters
c may have no solution, or may have two or more
c solutions, or may be indeterminate.
c
c acell Output Uniquely determined character in each cell.
c Set to achars(0) if not found.
c
c achars Input A set of 10 unique characters, with achars(0) used for
c an unassigned cell.
c
c nchars Output The final number of cells with characters assigned.
c The puzzle is solved if nchars = 81.
c
c nerr Output Error flag. No error if zero.
c 1 if any initially specified character is not one of
c the 10 unique characters of achars.
c 2 if fewer than 17 cells are initially assigned.
c 3 if a character used more than once in same row.
c 4 if a character used more than once in same column.
c 5 if a character used more than once in same box.
c 6 if an empty cell permits no characters.
c 7 if a character is assigned to 2 or more cells in
c the same row, column or box (aptsudx).
c 8 if all 81 cells could not be assigned.
c 9 if all 81 cells were assigned, but incorrectly.
c
c kperm Local Array kperm(nrow,ncol,idig), idigs = 1, 9, is the
c status of character achars(idig) in the cell at
c row nrow, col ncol:
c 0 if achars(idig) is not permitted,
c 1 if achars(idig) is permitted, but not yet assigned.
c 2 if achars(idig) as assigned to the cell.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc########
ccend.
implicit none
c.... Arguments.
character*1 achars(0:9) ! Characters in Sudoku grid.
character*1 acell(9,9) ! Character assigned to a cell.
integer nchars ! Number of characters assigned.
integer nerr ! Error flag, 0, 1 or 2.
c.... Local variables.
integer icell(9,9) ! Index of character assigned to a cell.
integer icells(9,9) ! Index of character assigned to a cell.
integer idig ! Index of character permitted in a cell.
integer idigx ! Index of character permitted in a cell.
integer icoltot(9) ! Number of assigned cells in a column.
integer iblock(9) ! Nuber of characters to block.
integer iboxtot(9) ! Number of assigned cells in a box.
integer idigs ! Index of character assigned to a cell.
integer idigtot(9) ! Number of cells for each character.
integer irowtot(9) ! Number of assigned cells in a row.
integer jcell ! Cell index of a cell in a box.
integer jcellx ! Cell index of a cell in a box.
integer kcount(9) ! Number of a particular character.
integer kperm(9,9,9) ! Status of row, col, character (0,1,2).
integer kperms(9,9,9) ! Status of row, col, character (0,1,2).
integer n ! General index, from 1 to 9.
integer npermit(9,9) ! # of characters permitted in empty cell.
integer nblock ! Number of characters to block.
integer nblocked ! Number of characters blocked.
integer nbox ! Box index, 1 to 9.
integer nchar ! Character index, 1 to 9.
integer ncharss ! Initial number of assigned characters.
integer ncol ! Column index, 1 to 9.
integer ncold ! Column index of a duplicate character.
integer ncolbeg ! Column index at start of box, 1 to 9.
integer ncoldup(9) ! Columns containing dup kperm in row.
integer ncolend ! Column index at end of box, 1 to 9.
integer ncolx ! Column index, 1 to 9.
integer nrow ! Row index, 1 to 9.
integer nrowd ! Row index of a duplicate character.
integer nrowdup(9) ! Rows containing dup kperm in column.
integer nrowend ! Row index at end of box, 1 to 9.
integer nrowbeg ! Row index at start of box, 1 to 9.
integer nrowx ! Row index, 1 to 9.
integer nrule ! Rule being applied to find character.
integer ntests ! Number of tests made to find character.
integer numcell ! # of characters permitted by a cell.
integer idigg ! Index of character guessed for a cell.
integer jguess ! Cell index of guessed character.
integer ncolg ! Column index of guessed character.
integer nrowg ! Row index of guessed character.
character*1 acells(9,9) ! Character assigned to a cell.
character*1 adigs ! Character in Sudoku grid.
character*1 adup ! Character duplicated in row, col, box.
cbugc***DEBUG begins.
cbug character*8 anot ! Blank or 'not'.
cbug 9001 format (/ 'aptsudo solving a Sudoku puzzle.' //
cbug & 'Rules:' //
cbug & ' Rule 1: Assign a character to a cell if that character' /
cbug & ' is the only character permitted in that cell',
cbug & ' (a naked single).' //
cbug & ' Rule 2: Assign a character to a cell if that character' /
cbug & ' is only permitted in one cell in a row',
cbug & ' (a hidden single).' //
cbug & ' Rule 3: Assign a character to a cell if that character' /
cbug & ' is only permitted in one cell in a column',
cbug & ' (a hidden single).' //
cbug & ' Rule 4: Assign a character to a cell if that character' /
cbug & ' is only permitted in one cell in a box',
cbug & ' (a hidden single).' //
cbug & ' Rule 5. Block a character from a cell if that character' /
cbug & ' is one of N characters that are the only characters' /
cbug & ' permitted in N other cells in a row.' //
cbug & ' Rule 6. Block a character from a cell if that character' /
cbug & ' is one of N characters that are the only characters' /
cbug & ' permitted in N other cells in a column.' //
cbug & ' Rule 7. Block a character from a cell if that character' /
cbug & ' is one of N characters that are the only characters' /
cbug & ' permitted in N other cells in a box.' )
cbug write ( 3, 9001)
cbugc***DEBUG ends.
c.... Test for errors.
nerr = 0
ntests = 0
nchars = 0
do nrow = 1, 9 ! Loop over rows.
do 110 ncol = 1, 9 ! Loop over columns.
acells(nrow,ncol) = acell(nrow,ncol)
icell(nrow,ncol) = -1
do nchar = 0, 9 ! Loop over characters.
if (acell(nrow,ncol) .eq. achars(nchar)) then
icell(nrow,ncol) = nchar
icells(nrow,ncol) = nchar
if (nchar .ne. 0) then
nchars = nchars + 1
endif
go to 110
endif
enddo ! End of loop over characters
cbugcbugc***DEBUG begins.
cbugcbug 9005 format (/ ' aptsudo ERROR. acell(',i1,',',i1,') = "',a1,'"')
cbugcbug write ( 3, 9005) nrow, ncol, acell(nrow,ncol)
cbugcbugc***DEBUG ends.
nerr = 1
go to 210
110 continue ! End of loop over columns.
enddo ! End of loop over rows.
ncharss = nchars
cbugcbugc***DEBUG begins.
cbugcbug 9010 format (/ 'aptsudo looking for characters. nerr =',i2 /
cbugcbug & 'Initial characters (',i2,'):' //
cbugcbug & ' |'23('-'),'|' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',23('-'),'|' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',23('-'),'|' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbugcbug & ' |',23('-'),'|' // )
cbugcbug write ( 3, 9010) nerr, nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c.... Test for duplicate characters in same row, column or box.
call aptsudu (achars, acell, adup, nrowd, ncold, nerr)
if (nerr .ne. 0) go to 210
cold
coldc.... Test for duplicate characters in same row.
cold
cold do nrow = 1, 9
cold do ncol = 1, 8
cold do ncolx = ncol + 1, 9
cold adigs = acell(nrow,ncol)
cold if (adigs .ne. achars(0)) then
cold if (adigs .eq. acell(nrow,ncolx)) then
cold nerr = 3
coldcbugcbugc***DEBUG begins.
coldcbugcbug 9020 format ('Duplicate characters in same row . nerr =',i2,
coldcbugcbug & ' nrow =',i2,' ncol =',i2,' adigs = "',a1,'"')
coldcbugcbug write ( 3, 9020) nerr, nrow, ncol, acell(nrow,ncol)
coldcbugcbugc***DEBUG ends.
cold go to 210
cold endif
cold endif
cold enddo
cold enddo
cold enddo
cold
coldc.... Test for duplicate characters in same column.
cold
cold do ncol = 1, 9
cold do nrow = 1, 8
cold do nrowx = nrow + 1, 9
cold adigs = acell(nrow,ncol)
cold if (adigs .ne. achars(0)) then
cold if (adigs .eq. acell(nrowx,ncol)) then
cold nerr = 4
coldcbugcbugc***DEBUG begins.
coldcbugcbug 9025 format ('Duplicate characters in same column. nerr =',i2,
coldcbugcbug & ' nrow =',i2,' ncol =',i2,' adigs = "',a1,'"')
coldcbugcbug write ( 3, 9025) nerr, nrow, ncol, acell(nrow,ncol)
coldcbugcbugc***DEBUG ends.
cold go to 210
cold endif
cold endif
cold enddo
cold enddo
cold enddo
cold
coldc.... Test for duplicate characters in same box.
cold
cold do nrow = 1, 7, 3
cold do ncol = 1, 7, 3
cold do idigs = 1, 9
cold kcount(idigs) = 0
cold enddo
cold
cold do nrowx = nrow, nrow + 2
cold do ncolx = ncol, ncol + 2
cold idigs = icell(nrowx,ncolx)
cold if (idigs .ne. 0) then
cold kcount(idigs) = kcount(idigs) + 1
cold endif
cold enddo
cold enddo
cold
cold do idigs = 1, 9
cold if (kcount(idigs) .gt. 1) then
cold nerr = 5
coldcbugcbugc***DEBUG begins.
coldcbugcbug 9030 format ('Duplicate characters in same box . nerr =',i2,
coldcbugcbug & ' nrow =',i2,' ncol =',i2,' idigs = "',a1,'"')
coldcbugcbug write ( 3, 9030) nerr, nrow, ncol, achars(idig)
coldcbugcbugc***DEBUG ends.
cold endif
cold enddo
cold
cold enddo
cold enddo
if (nchars .lt. 17) then
nerr = 2
go to 210
endif
if (nerr .ne. 0) go to 210
if (nchars .eq. 81) go to 210
c.... Initialize statuses, to permit all characters in each cell.
do nrow = 1, 9
do ncol = 1, 9
do idigs = 1, 9
kperm(nrow,ncol,idigs) = 1
enddo
npermit(nrow,ncol) = 9
enddo
enddo
c.... Find actual status of each of 9 characters in each cell.
do nrow = 1, 9
do ncol = 1, 9
if (icell(nrow,ncol) .ne. 0) then ! Found a specified character.
idigs = icell(nrow,ncol)
c.... Do not permit same character in same row, column or box.
call aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)
if (nerr .ne. 0) then
nerr = 7
go to 210
endif
endif ! Found init assigned character (IAD).
enddo ! End of loop over columns.
enddo ! End of loop over rows.
c.... Count assigned characters.
nchars = 0
do nrow = 1, 9
do ncol = 1, 9
if (acell(nrow,ncol) .ne. achars(0)) then
nchars = nchars + 1
cbugcbugc***DEBUG begins.
cbugcbug 9050 format (/ ' Row',i2,', column',i2,' is initially "',a1,'".')
cbugcbug write ( 3, 9050) nrow, ncol, acell(nrow,ncol)
cbugcbugc***DEBUG ends.
else
cbugcbugc***DEBUG begins.
cbugcbug 9055 format (/ ' Row',i2,', column',i2,' is initially blank.' /
cbugcbug & ' Digit: 1 2 3 4 5 6 7 8 9' /
cbugcbug & ' Status: ',9i2 )
cbugcbug write ( 3, 9055) nrow, ncol, (kperm(nrow,ncol,idig), idig = 1, 9)
cbugcbugc***DEBUG ends.
endif
enddo
enddo
c=======================================================================********
ntests = 0
c.... Return here after each new character is assigned.
100 nchars = 0
c.... Initialize totals of assigned characters in grid, rows, columns, boxes.
do n = 1, 9
idigtot(n) = 0
irowtot(n) = 0
icoltot(n) = 0
iboxtot(n) = 0
enddo
c.... Count assigned characters.
do nrow = 1, 9
do ncol = 1, 9
npermit(nrow,ncol) = 0
idigs = icell(nrow,ncol)
if (idigs .ne. 0) then
nchars = nchars + 1
nbox = 1 + 3 * ((nrow - 1) / 3) + (ncol - 1) / 3
c.... nrowbeg = 1 + (nbox - 1) / 3
c.... ncolbeg = 1 + 3 * mod ((nbox - 1), 3)
cbugcbugc***DEBUG begins.
cbugcbug 9060 format ('DEBUG nrow,ncol,nbox=',3i2)
cbugcbug write ( 3, 9060) nrow, ncol, nbox
cbugcbugc***DEBUG ends.
idigtot(idigs) = idigtot(idigs) + 1
irowtot(nrow) = irowtot(nrow) + 1
icoltot(ncol) = icoltot(ncol) + 1
iboxtot(nbox) = iboxtot(nbox) + 1
else
do idigs = 1, 9
if (kperm(nrow,ncol,idigs) .eq. 1) then
npermit(nrow,ncol) = npermit(nrow,ncol) + 1
endif
enddo
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9930) nrow, ncol, (kperm(nrow,ncol,idig), idig = 1, 9),
cbugcbug & npermit(nrow,ncol)
cbugcbugc***DEBUG ends.
endif
enddo ! End of loop over columns.
enddo ! End of loop over rows.
cbugcbugc***DEBUG begins.
cbugcbug 9065 format (/ 'Digit totals: 1 2 3 4 5 6 7 8 9' /
cbugcbug & 14x,9i2)
cbugcbug 9070 format (/ 'Row totals: 1 2 3 4 5 6 7 8 9' /
cbugcbug & 14x,9i2)
cbugcbug 9075 format (/ 'Col totals: 1 2 3 4 5 6 7 8 9' /
cbugcbug & 14x,9i2)
cbugcbug 9080 format (/ 'Box totals: 1 2 3 4 5 6 7 8 9' /
cbugcbug & 14x,9i2)
cbugcbug write ( 3, 9065) (idigtot(idig), idig = 1, 9)
cbugcbug write ( 3, 9070) (irowtot(nrow), nrow = 1, 9)
cbugcbug write ( 3, 9075) (icoltot(ncol), ncol = 1, 9)
cbugcbug write ( 3, 9080) (iboxtot(nbox), nbox = 1, 9)
cbugcbugc***DEBUG ends.
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c.... See if solution has been found.
if (nchars .eq. 81) go to 210
cbugcbugc***DEBUG begins.
cbugcbug if (ntests .ge. 30000) then
cbugcbug go to 210
cbugcbug endif
cbugcbugc***DEBUG ends.
c=======================================================================********
c.... Rule 1: Assign a character to a cell if that character is the
c.... only character permitted in that cell.
nrule = 1
cbugcbugc***DEBUG begins.
cbugcbug 9110 format (// 'Starting Rule',i2,'.')
cbugcbug 9120 format (/ 'Looking for cells with only one permitted character.' )
cbugcbug write ( 3, 9110) nrule
cbugcbug write ( 3, 9120)
cbugcbugc***DEBUG ends.
do 180 nrow = 1, 9
do 170 ncol = 1, 9
if (icell(nrow,ncol) .ne. 0) go to 170
ntests = ntests + 1
numcell = 0
idigs = 0
do 130 idig = 1, 9
if (kperm(nrow,ncol,idig) .ne. 1) go to 130
numcell = numcell + 1
idigs = idig
130 continue ! End of loop over possible characters.
if (numcell .ne. 1) go to 170
icell(nrow,ncol) = idigs
acell(nrow,ncol) = achars(idigs)
cbugcbugc***DEBUG begins.
cbugcbug 9140 format (' Row',i2,', column',i2,' is assigned "',a1,'"',
cbugcbug & ', by Rule',i2,'.')
cbugcbug write ( 3, 9140) nrow, ncol, acell(nrow,ncol), nrule
cbugcbugc***DEBUG ends.
c.... Do not permit same character in same row, column or box.
call aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)
if (nerr .ne. 0) then
nerr = 7
go to 210
endif
go to 100
170 continue ! End of loop over columns. Rule 1.
180 continue ! End of loop over rows. Rule 1.
cbugcbugc***DEBUG begins.
cbugcbug 9170 format (/ 'No characters were assigned in grid.' )
cbugcbug write ( 3, 9170)
cbugcbugc***DEBUG ends.
cbugcbugc***DEBUG begins.
cbugcbug 9180 format (/ 'aptsudo looking for characters. nerr =',i2,'.' )
cbugcbug write ( 3, 9180) nerr
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c.... End of Rule 1.
c=======================================================================********
c.... Rule 2: Assign a character to a cell if that character is only
c.... permitted in one cell in a row.
nrule = 2
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9110) nrule
cbugcbugc***DEBUG ends.
do 260 nrow = 1, 9 ! Loop over rows.
cbugcbugc***DEBUG begins.
cbugcbug 9210 format (/ 'Looking for character permitted in only one cell',
cbugcbug & ' in row',i2,'.')
cbugcbug write ( 3, 9210) nrow
cbugcbugc***DEBUG ends.
do 240 idigs = 1, 9 ! Loop over possible characters.
c.... See if character is permitted in only one cell in this row.
numcell = 0
ncol = 0
do 220 ncolx = 1, 9 ! Loop over columns in this row.
ntests = ntests + 1
if (kperm(nrow,ncolx,idigs) .eq. 1) then
numcell = numcell + 1
ncol = ncolx
endif
220 continue
if (numcell .eq. 1) then ! Found a required character in row.
icell(nrow,ncol) = idigs
acell(nrow,ncol) = achars(idigs)
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9140) nrow, ncol, acell(nrow,ncol), nrule
cbugcbugc***DEBUG ends.
c.... Do not permit same character in same row, column or box.
call aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)
if (nerr .ne. 0) then
nerr = 7
go to 210
endif
go to 100
endif
240 continue ! End of loop over possible characters.
cbugcbugc***DEBUG begins.
cbugcbug 9240 format (/ 'No characters were assigned in row',i2,'.' )
cbugcbug write ( 3, 9240) nrow
cbugcbugc***DEBUG ends.
260 continue ! End of loop over rows. Rule 2.
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9180) nerr
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c.... End of Rule 2.
c=======================================================================********
c.... Rule 3: Assign a character to a cell if that character is only
c.... permitted in one cell in a column.
nrule = 3
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9110) nrule
cbugcbugc***DEBUG ends.
do 360 ncol = 1, 9 ! Loop over columns.
cbugcbugc***DEBUG begins.
cbugcbug 9320 format (/ 'Looking for character permitted in only one cell',
cbugcbug & ' in column',i2,'.')
cbugcbug write ( 3, 9320) ncol
cbugcbugc***DEBUG ends.
do 350 idigs = 1, 9 ! Loop over possible characters.
c.... See if character is permitted in only one cell in this column.
numcell = 0
nrow = 0
do 320 nrowx = 1, 9 ! Loop over rows in this column.
ntests = ntests + 1
if (kperm(nrowx,ncol,idigs) .eq. 1) then
numcell = numcell + 1
nrow = nrowx
endif
320 continue
if (numcell .ne. 1) go to 350
icell(nrow,ncol) = idigs
acell(nrow,ncol) = achars(idigs)
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9140) nrow, ncol, acell(nrow,ncol), nrule
cbugcbugc***DEBUG ends.
c.... Do not permit same character in same row, column or box.
call aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)
if (nerr .ne. 0) then
nerr = 7
go to 210
endif
go to 100
350 continue ! End of loop over possible characters.
cbugcbugc***DEBUG begins.
cbugcbug 9350 format (/ 'No characters were assigned in column',i2,'.' )
cbugcbug write ( 3, 9350) ncol
cbugcbugc***DEBUG ends.
360 continue ! End of loop over columns.
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9180) nerr
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c.... End of Rule 3.
c=======================================================================********
c.... Rule 4: Assign a character to a cell if that character is only
c.... permitted in one cell in a box.
nrule = 4
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9110) nrule
cbugcbugc***DEBUG ends.
do 480 nrowbeg = 1, 7, 3 ! Loop over rows beginning boxes.
nrowend = nrowbeg + 2
do 470 ncolbeg = 1, 7, 3 ! Loop over columns beginning boxes.
ncolend = ncolbeg + 2
nbox = 1 + 3 * ((nrowbeg - 1) / 3) + (ncolbeg - 1) / 3
cbugcbugc***DEBUG begins.
cbugcbug 9410 format (/ 'Looking for character permitted in only one cell',
cbugcbug & ' in box',i2,'.')
cbugcbug write ( 3, 9410) nbox
cbugcbugc***DEBUG ends.
do 460 idigs = 1, 9 ! Loop over characters.
c.... See if character is permitted in only one cell in this box.
numcell = 0
nrow = 0
ncol = 0
do 450 nrowx = nrowbeg, nrowend ! Loop over rows in this box.
do 440 ncolx = ncolbeg, ncolend ! Loop over columns in this box.
ntests = ntests + 1
if (kperm(nrowx,ncolx,idigs) .eq. 1) then
numcell = numcell + 1
nrow = nrowx
ncol = ncolx
endif
440 continue ! End of row loop in this box.
450 continue ! End of column loop in this box.
if (numcell .ne. 1) go to 460
icell(nrow,ncol) = idigs
acell(nrow,ncol) = achars(idigs)
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9140) nrow, ncol, acell(nrow,ncol), nrule
cbugcbugc***DEBUG ends.
c.... Do not permit same character in same row, column or box.
call aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)
if (nerr .ne. 0) then
nerr = 7
go to 210
endif
go to 100
460 continue ! End of loop over possible characters.
cbugcbugc***DEBUG begins.
cbugcbug 9460 format (/ 'No characters were assigned in box',i2,'.' )
cbugcbug write ( 3, 9460) nbox
cbugcbugc***DEBUG ends.
470 continue ! End of loop over rows in this box.
480 continue ! End of loop over columns in this box.
c.... End of Rule 4.
c=======================================================================********
c.... Rule 5. Block a character from a cell if that character is one of 2
c.... characters that are the only characters permitted in 2 other cells
c.... in the same row.
nrule = 5
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9110) nrule
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbug write ( 3, 9220) ((npermit(nrow,ncol), ncol = 1, 9), nrow = 1, 9)
cbugcbugc***DEBUG ends.
do 580 nrow = 1, 9 ! Loop over rows.
cbugcbugc***DEBUG begins.
cbugcbug 9520 format (/ 'Looking for duplicate pairs in row',i2,'.')
cbugcbug write ( 3, 9520) nrow
cbugcbugc***DEBUG ends.
c.... Find any pairs of cells with only the same 2 characters permitted.
do 550 ncol = 1, 8 ! Loop over columns in this row.
if (npermit(nrow,ncol) .ne. 2) go to 550
cbugcbugc***DEBUG begins.
cbugcbug 9530 format (/ 'Row',i2,' column',i2,' permits only 2 characters: ',
cbugcbug & 9i2)
cbugcbug 9540 format ( 'Row',i2,' column',i2,' permits only 2 characters: ',
cbugcbug & 9i2)
cbugcbug write ( 3, 9530) nrow, ncol, (kperm(nrow,ncol,n), n = 1, 9)
cbugcbugc***DEBUG ends.
nblock = 0
ncoldup(1) = ncol
do 540 ncolx = ncol + 1, 9 ! Loop over remaining columns.
ntests = ntests + 1
if (npermit(nrow,ncolx) .ne.
& npermit(nrow,ncol)) go to 530
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9540) nrow, ncolx, (kperm(nrow,ncolx,n), n = 1, 9)
cbugcbugc***DEBUG ends.
do 520 idigs = 1, 9 ! Loop over characters.
if (kperm(nrow,ncol,idigs) .eq. 0) go to 520
if (kperm(nrow,ncol,idigs) .ne.
& kperm(nrow,ncolx,idigs)) then
go to 540
else
ncoldup(2) = ncolx
nblock = nblock + 1
iblock(nblock) = idigs
endif
520 continue ! End of loop over characters.
cbugcbugc***DEBUG begins.
cbugcbug if (nblock .eq. 2) then
cbugcbug 9550 format (/ 'A match exists for column',i2,'.')
cbugcbug 9555 format ('In all columns except',i2,' and',i2,
cbugcbug & ' block characters',i2,' and',i2,'.')
cbugcbug write ( 3, 9550) ncol
cbugcbug write ( 3, 9555) ncoldup(1), ncoldup(2), iblock(1), iblock(2)
cbugcbug endif
cbugcbugc***DEBUG ends.
530 if (nblock .eq. 2) go to 555 ! NEW.
540 continue ! End of loop over remaining columns.
cbugcbugc***DEBUG begins.
cbugcbug 9560 format (/ 'No match exists for column',i2,'.')
cbugcbug if (nblock .ne. 2) then
cbugcbug write ( 3, 9560) ncol
cbugcbug endif
cbugcbugc***DEBUG ends.
550 continue ! End of loop over columns.
c.... Block the two characters in all other cells in the same row.
555 nblocked = 0 ! NEW.
if (nblock .eq. 2) then ! Found pair of cells with same 2 permitted.
do 560 ncol = 1, 9
cbugcbugc***DEBUG begins.
cbugcbug 9570 format ('is col',i2,' either',i2,' or',i2,'?')
cbugcbug write ( 3, 9570) ncol, ncoldup(1), ncoldup(2)
cbugcbugc***DEBUG ends.
if ((ncol .eq. ncoldup(1)) .or.
& (ncol .eq. ncoldup(2))) go to 560
idigs = iblock(1)
if (kperm(nrow,ncol,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug 9580 format (' Row',i2,', column',i2,' character',i2,
cbugcbug & ' is blocked , by Rule',i2,'.')
cbugcbug write ( 3, 9580) nrow, ncol, idigs, nrule
cbugcbugc***DEBUG ends.
nblocked = nblocked + 1
kperm(nrow,ncol,idigs) = 0
npermit(nrow,ncol) = npermit(nrow,ncol) - 1
endif
idigs = iblock(2)
if (kperm(nrow,ncol,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9580) nrow, ncol, idigs, nrule
cbugcbugc***DEBUG ends.
nblocked = nblocked + 1
kperm(nrow,ncol,idigs) = 0
npermit(nrow,ncol) = npermit(nrow,ncol) - 1
endif
560 continue
endif ! 2 cells permit only same 2 characters.
if (nblocked .gt. 0) go to 100
cbugcbugc***DEBUG begins.
cbugcbug 9590 format (/ 'No characters were blocked in row',i2,'.')
cbugcbug write ( 3, 9590) nrow
cbugcbugc***DEBUG ends.
580 continue ! End of loop over rows. Rule 5.
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9180) nerr
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c=======================================================================********
c.... Rule 6. Block a character from a cell if that character is one of 2
c.... characters that are the only characters permitted in 2 other cells
c.... in the same column.
nrule = 6
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9110) nrule
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbug write ( 3, 9220) ((npermit(nrow,ncol), ncol = 1, 9), nrow = 1, 9)
cbugcbugc***DEBUG ends.
do 680 ncol = 1, 9 ! Loop over columns.
cbugcbugc***DEBUG begins.
cbugcbug 9620 format (/ 'Looking for duplicate pairs in column',i2,'.')
cbugcbug write ( 3, 9620) ncol
cbugcbugc***DEBUG ends.
c.... Find any pairs of cells with only the same 2 characters permitted.
do 650 nrow = 1, 8 ! Loop over rows in this column.
if (npermit(nrow,ncol) .ne. 2) go to 650
cbugcbugc***DEBUG begins.
cbugcbug 9630 format (/ 'Row',i2,' column',i2,' permits only 2 characters: ',
cbugcbug & 9i2)
cbugcbug 9640 format ( 'Row',i2,' column',i2,' permits only 2 characters: ',
cbugcbug & 9i2)
cbugcbug write ( 3, 9630) nrow, ncol, (kperm(nrow,ncol,n), n = 1, 9)
cbugcbugc***DEBUG ends.
nblock = 0
nrowdup(1) = nrow
do 640 nrowx = nrow + 1, 9 ! Loop over remaining rows.
ntests = ntests + 1
if (npermit(nrowx,ncol) .ne. npermit(nrow,ncol)) then
go to 635
endif
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9640) nrowx, ncol, (kperm(nrowx,ncol,n), n = 1, 9)
cbugcbugc***DEBUG ends.
do 620 idigs = 1, 9 ! Loop over characters.
if (kperm(nrow,ncol,idigs) .eq. 0) go to 620
if (kperm(nrow,ncol,idigs) .ne.
& kperm(nrowx,ncol,idigs)) go to 640
nrowdup(2) = nrowx
nblock = nblock + 1
iblock(nblock) = idigs
620 continue ! End of loop over characters.
cbugcbugc***DEBUG begins.
cbugcbug if (nblock .eq. 2) then
cbugcbug 9650 format (/ 'A match exists for row',i2,'.')
cbugcbug 9660 format ('In all rows except',i2,' and',i2,
cbugcbug & ' block characters',i2,' and',i2,'.')
cbugcbug write ( 3, 9650) nrow
cbugcbug write ( 3, 9660) nrowdup(1), nrowdup(2), iblock(1), iblock(2)
cbugcbug endif
cbugcbugc***DEBUG ends.
635 if (nblock .eq. 2) go to 665 ! NEW.
640 continue ! End of loop over remaining rows.
cbugcbugc***DEBUG begins.
cbugcbug 9670 format (/ 'No match exists for column',i2,'.')
cbugcbug if (nblock .ne. 2) then
cbugcbug write ( 3, 9670) nrow
cbugcbug endif
cbugcbugc***DEBUG ends.
650 continue ! End of loop over rows.
c.... Block the two characters in all other cells in the same column.
665 nblocked = 0 ! NEW.
if (nblock .ne. 2) go to 670
do 660 nrow = 1, 9
cbugcbugc***DEBUG begins.
cbugcbug 9680 format ('is row',i2,' either',i2,' or',i2,'?')
cbugcbug write ( 3, 9680) nrow, nrowdup(1), nrowdup(2)
cbugcbugc***DEBUG ends.
if ((nrow .eq. nrowdup(1)) .or.
& (nrow .eq. nrowdup(2))) go to 660
idigs = iblock(1)
if (kperm(nrow,ncol,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug 9685 format (' Row',i2,', column',i2,' character',i2,
cbugcbug & ' is blocked , by Rule',i2,'.')
cbugcbug write ( 3, 9685) nrow, ncol, idigs, nrule
cbugcbugc***DEBUG ends.
nblocked = nblocked + 1
kperm(nrow,ncol,idigs) = 0
npermit(nrow,ncol) = npermit(nrow,ncol) - 1
endif
idigs = iblock(2)
if (kperm(nrow,ncol,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9685) nrow, ncol, idigs, nrule
cbugcbugc***DEBUG ends.
nblocked = nblocked + 1
kperm(nrow,ncol,idigs) = 0
npermit(nrow,ncol) = npermit(nrow,ncol) - 1
endif
660 continue
670 if (nblocked .gt. 0) go to 100
cbugcbugc***DEBUG begins.
cbugcbug 9690 format (/ 'No characters were blocked in column',i2,'.')
cbugcbug write ( 3, 9690) ncol
cbugcbugc***DEBUG ends.
680 continue ! End of loop over columns. Rule 6.
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9180) nerr
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c=======================================================================********
c.... Rule 7. Block a character from a cell if that character is one of 2
c.... characters that are the only characters permitted in 2 other cells
c.... in the same box.
nrule = 7
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9110) nrule
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbug write ( 3, 9220) ((npermit(nrow,ncol), ncol = 1, 9), nrow = 1, 9)
cbugcbugc***DEBUG ends.
do 795 nrowbeg = 1, 7, 3 ! Loop over rows beginning boxes.
nrowend = nrowbeg + 2
do 790 ncolbeg = 1, 7, 3 ! Loop over columns beginning boxes.
ncolend = ncolbeg + 2
nbox = 1 + 3 * ((nrowbeg - 1) / 3) + (ncolbeg - 1) / 3
cbugcbugc***DEBUG begins.
cbugcbug 9710 format (/ 'Looking for duplicate pairs in box',i2,'.')
cbugcbug write ( 3, 9710) nbox
cbugcbugc***DEBUG ends.
c.... Find any pairs of cells with only the same 2 characters permitted.
c.... Loop over cells in this box to find one permiting 2 characters.
do 750 nrow = nrowbeg, nrowend ! Loop over rows in this box.
do 740 ncol = ncolbeg, ncolend ! Loop over columns in this box.
if (npermit(nrow,ncol) .ne. 2) go to 740
cbugcbugc***DEBUG begins.
cbugcbug 9720 format (/ 'Row',i2,' column',i2,' permits only 2 characters: ',
cbugcbug & 9i2)
cbugcbug 9730 format ( 'Row',i2,' column',i2,' permits only 2 characters: ',
cbugcbug & 9i2)
cbugcbug write ( 3, 9720) nrow, ncol, (kperm(nrow,ncol,n), n = 1, 9)
cbugcbugc***DEBUG ends.
nblock = 0
nrowdup(1) = nrow
ncoldup(1) = ncol
jcell = ncol + 9 * (nrow - 1)
c.... Loop over rest of cells in this box to find matching pair of characters.
do 730 nrowx = nrowbeg, nrowend ! Loop over rows in this box.
do 720 ncolx = ncolbeg, ncolend ! Loop over columns in this box.
ntests = ntests + 1
jcellx = ncolx + 9 * (nrowx - 1)
if (jcellx .le. jcell) go to 720
if (npermit(nrowx,ncolx) .ne. npermit(nrow,ncol)) go to 715
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9730) nrowx, ncolx, (kperm(nrowx,ncolx,n), n = 1, 9)
cbugcbugc***DEBUG ends.
c.... See if two characters are the same as initial cell.
do 710 idigs = 1, 9 ! Loop over characters in this cell.
if (kperm(nrowx,ncolx,idigs) .eq. 0) go to 710
if (kperm(nrow,ncol,idigs) .ne.
& kperm(nrowx,ncolx,idigs)) go to 720
nrowdup(2) = nrowx
ncoldup(2) = ncolx
nblock = nblock + 1
iblock(nblock) = idigs
710 continue ! End of loop over characters in cell.
cbugcbugc***DEBUG begins.
cbugcbug if (nblock .eq. 2) then
cbugcbug 9731 format (/ 'A match exists for cell nrow =',i2,' ncol =',i2,'.' /
cbugcbug & 'A match exists for cell nrow =',i2,' ncol =',i2,'.')
cbugcbug 9740 format ('In all cells except for row',i2,' col',i2,
cbugcbug & ' and row',i2,' col',i2,' block characters',i2,' and',i2,'.')
cbugcbug write ( 3, 9731) nrow, ncol, nrowx, ncolx
cbugcbug write ( 3, 9740) nrowdup(1), ncoldup(1), nrowdup(2), ncoldup(2),
cbugcbug & iblock(1), iblock(2)
cbugcbug endif
cbugcbugc***DEBUG ends.
715 if (nblock .eq. 2) go to 760 ! NEW.
720 continue ! End of loop over columns in this box.
730 continue ! End of loop over remaining cells.
cbugcbugc***DEBUG begins.
cbugcbug 9750 format (/ 'No match exists for nrow',i2,', column',i2,'.')
cbugcbug if (nblock .ne. 2) then
cbugcbug write ( 3, 9750) nrow, ncol
cbugcbug endif
cbugcbugc***DEBUG ends.
740 continue ! End of loop over columns in this box.
750 continue ! End of loop over rows in this box.
c.... Block the two characters in all other cells in the same box.
760 nblocked = 0 ! NEW.
if (nblock .eq. 2) then ! Found pair of cells with same 2 permitted.
c.... Block either character in any other cells in this box.
do 780 nrow = nrowbeg, nrowend ! Loop over rows in this box.
do 770 ncol = ncolbeg, ncolend ! Loop over columns in this box.
if ((nrow .eq. nrowdup(1)) .and.
& (ncol .eq. ncoldup(1))) go to 770
if ((nrow .eq. nrowdup(2)) .and.
& (ncol .eq. ncoldup(2))) go to 770
idigs = iblock(1)
if (kperm(nrow,ncol,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug 9760 format (' Row',i2,', column',i2,' character',i2,
cbugcbug & ' is blocked , by Rule',i2,'.')
cbugcbug write ( 3, 9760) nrow, ncol, idigs, nrule
cbugcbugc***DEBUG ends.
nblocked = nblocked + 1
kperm(nrow,ncol,idigs) = 0
npermit(nrow,ncol) = npermit(nrow,ncol) - 1
endif
idigs = iblock(2)
if (kperm(nrow,ncol,idigs) .eq. 1) then
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9685) nrow, ncol, idigs, nrule
cbugcbugc***DEBUG ends.
nblocked = nblocked + 1
kperm(nrow,ncol,idigs) = 0
npermit(nrow,ncol) = npermit(nrow,ncol) - 1
endif
770 continue ! End of loop over cols in this box.
780 continue ! End of loop over rows in this box.
endif ! Two cells permit only same 2 characters.
if (nblocked .gt. 0) go to 100
cbugcbugc***DEBUG begins.
cbugcbug 9770 format (/ 'No characters were blocked in box',i2,'.')
cbugcbug write ( 3, 9770) nbox
cbugcbugc***DEBUG ends.
790 continue ! End of loop over cols beginning boxes.
795 continue ! End of loop over rows beginning boxes.
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9180) nerr
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
c.... End of Rule 7.
c=======================================================================********
c.... Rule 8. Try backtracking.
c.... See if any cells have no possible choices.
nrule = 8
cbugcbugc***DEBUG begins.
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends.
do 830 nrow = 1, 9 ! Loop over rows.
do 820 ncol = 1, 9 ! Loop over columns.
ntests = ntests + 1
if (icell(nrow,ncol) .ne. 0) go to 820
if (npermit(nrow,ncol) .eq. 0) then ! Impossible cell was found.
go to 840
endif ! Impossible cell was found.
820 continue ! End of loop over columns.
830 continue ! End of loop over rows.
c.... No impossible cells. Save current assignments.
do nrow = 1, 9
do ncol = 1, 9
icells(nrow,ncol) = icell(nrow,ncol)
acells(nrow,ncol) = acell(nrow,ncol)
do idigs = 1, 9
kperms(nrow,ncol,idigs) = kperm(nrow,ncol,idigs)
enddo
enddo
enddo
c.... Make a new guess.
go to 860
c.... Found a bad cell. Last guess was bad.
840 continue
cbugcbugc***DEBUG begins.
cbugcbug 9810 format (/ ' Row',i2,', column',i2,' permits no characters.',
cbugcbug & ' IMPOSSIBLE! LAST GUESS WAS BAD!' )
cbugcbug 9820 format (/ ' Row',i2,', column',i2,', character "',a1,'" was',
cbugcbug & ' a BAD GUESS!' )
cbugcbug write ( 3, 9810) nrow, ncol
cbugcbug if (idigg .ne. 0) then ! NEW
cbugcbug write ( 3, 9820) nrowg, ncolg, achars(idigg)
cbugcbug endif ! NEW
cbugcbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbugcbug & nrow = 1, 9)
cbugcbugc***DEBUG ends
c.... Restore old cell assignments.
do nrow = 1, 9
do ncol = 1, 9
icell(nrow,ncol) = icells(nrow,ncol)
acell(nrow,ncol) = acells(nrow,ncol)
do idigs = 1, 9
kperm(nrow,ncol,idigs) = kperms(nrow,ncol,idigs)
enddo
enddo
enddo
c.... Do not permit guessed digit.
if (idigg .ne. 0) then
kperm(nrowg,ncolg,idigg) = 0
endif
c.... Make a new guess.
860 nrowg = 0
ncolg = 0
idigg = 0
do nrow = 1, 9
do ncol = 1, 9
do idigs = 1, 9
if (kperm(nrow,ncol,idigs) .eq. 1) then ! Found a new guess.
nrowg = nrow
ncolg = ncol
idigg = idigs
icell(nrow,ncol) = idigs
acell(nrow,ncol) = achars(idigs)
kperms(nrow,ncol,idigs) = 0 ! TRY !!!!
cbugcbugc***DEBUG begins.
cbugcbug 9830 format (/ ' Row',i2,', column',i2,' is assigned "',a1,'"',
cbugcbug & ', by Rule',i2,'. A GUESS.')
cbugcbug write ( 3, 9830) nrow, ncol, acell(nrow,ncol), nrule
cbugcbugc***DEBUG ends.
c.... Do not permit same character in same row, column or box.
call aptsudx (idigs, nrow, ncol, kperm, npermit, nerr)
if (nerr .ne. 0) then
nerr = 7
go to 210
endif
go to 100
endif ! Found a new guess.
enddo ! End of loop over digits.
enddo ! End of loop over columns.
enddo ! End of loop over rows.
c=======================================================================********
210 continue
c.... Test for good solution.
if ((nerr .eq. 0) .and. (nchars .ne. 81)) then
nerr = 8
endif
if (nerr .eq. 0) then
do n = 1, 9
if (idigtot(n) .ne. 9) nerr = 9
if (irowtot(n) .ne. 9) nerr = 9
if (icoltot(n) .ne. 9) nerr = 9
if (iboxtot(n) .ne. 9) nerr = 9
enddo
endif
cbugc***DEBUG begins.
cbug 9910 format (/ 'aptsudo did ',a3,' solve a Sudoku puzzle. nerr =',i2,
cbug & ', nchars =',i3,' (',i3,').' /
cbug & ' Number of tests made =',i6,'.' )
cbug
cbug 9920 format (/ 'Assigned characters: (',i2,')' //
cbug & ' |'23('-'),'|' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',23('-'),'|' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',23('-'),'|' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',3(1x,a1),' |',3(1x,a1),' |',3(1x,a1),' |' /
cbug & ' |',23('-'),'|' // )
cbug 9930 format (/ ' Row',i2,', column',i2,' is still empty.' /
cbug & ' Digit: 1 2 3 4 5 6 7 8 9' /
cbug & ' Status: ',9i2,' Allowed =',i2 )
cbug
cbug if (nchars .eq. 81) then
cbug anot = ' '
cbug else
cbug anot = 'not'
cbug do nrow = 1, 9
cbug do ncol = 1, 9
cbug if (icell(nrow,ncol) .eq. 0) then
cbug write ( 3, 9930) nrow, ncol,
cbug & (kperm(nrow,ncol,idig), idig = 1, 9), npermit(nrow,ncol)
cbug endif
cbug enddo
cbug enddo
cbug endif
cbug
cbug write ( 3, 9910) anot, nerr, nchars, ncharss, ntests
cbug write ( 3, 9920) nchars, ((acell(nrow,ncol), ncol = 1, 9),
cbug & nrow = 1, 9)
cbug
cbug 9220 format (/ 'Number of characters 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
cbug write ( 3, 9220) ((npermit(nrow,ncol), ncol = 1, 9), nrow = 1, 9)
cbugc***DEBUG ends.
return
c.... End of subroutine aptsudo. (+1 line.)
end
UCRL-WEB-209832