subroutine aptchia (iword, nbase, asink, iend, ibeg, nchar, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTCHIA
c
c call aptchia (iword, nbase, asink, iend, ibeg, nchar, nerr)
c
c Version: aptchia Updated 1991 December 6 9:30.
c aptchia Originated 1991 December 5 11:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To translate the binary integer number iword into integer
c ASCII characters, with number base nbase (8, 10 or 16), and
c store them into asink, right-adjusted to the iend'th character,
c and return the character position ibeg in asink in which the
c leftmost character was stored, and the total number of
c characters stored, nchar.
c Flag nerr indicates any input or result error.
c
c Input: iword, nbase, asink, iend.
c
c Output: asink, ibeg, nchar, nerr.
c
c Glossary:
c
c asink In/Out A character word or array, containing at least iend
c characters. Character positions are counted from
c left to right, starting with 1.
c
c ibeg Output The character position in asink where the leftmost
c (most significant) digit, or any leading minus sign,
c translated from iword was stored.
c Note: meaningless if nchar = 0.
c
c iend Input The character position in asink where the rightmost
c (least significant) digit translated from iword is to
c be stored. Must be positive.
c
c iword Input An integer. No more than iend digits, including any
c leading minus sign, will be stored in asink.
c If iword is zero, a single ASCII "0" will be stored
c in aword. Other leading zeros will not be stored.
c
c nbase Input The number base for the translation. May be 8 (octal),
c 10 (decimal), or 16 (hexadecimal).
c
c nchar Output The number of characters, including any leading minus
c sign, translated from iword and stored in asink.
c Note: may be zero if nerr = 5.
c
c nerr Output Indicates an input or a result error, if not zero.
c 1 if nbase is not 8, 10, or 16.
c 2 if iend is not positive. Then nchar = 0 and
c ibeg = 0 will be returned.
c 3 if iword contains more than iend digits.
c The first iend digits will be stored in asink.
c 4 if iword contains exactly iend digits and is
c negative. All iend digits will be stored in
c asink, but with no leading minus sign.
c 5 if iword is not recognizable as an integer.
c Note: if no characters are stored in asink, then
c nchar = 0 and ibeg = iend + 1 will be returned.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Array containing character string.
dimension asink (1)
c---- Array containing character string.
character asink*1
c.... Local variables.
c---- Index in asink.
common /laptchia/ i
c---- Index in adigit.
common /laptchia/ idig
c---- Truncated integer.
common /laptchia/ iwork
c---- Next truncated integer.
common /laptchia/ iworn
character*1 aquote
c---- Array of ASCII digits.
character*1 adigit(0:15)
data adigit / '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
& 'a', 'b', 'c', 'd', 'e', 'f' /
cbugc***DEBUG begins.
cbugc---- Result label.
cbug common /captchia/ abad(0:5)
cbug data abad / ' ', 'NBASE', 'IEND BAD', 'TOO BIG',
cbug & '-TOO BIG', 'NOT INT' /
cbugc---- Result label.
cbug character*8 abad
cbug aquote = '"'
cbug 9901 format (/ 'aptchia translating integer to ASCII. nbase=',i3,
cbug & ' iend=',i3 /
cbug & ' iword=',i20,' or ',o22,'b',' or ',z16,'#')
cbug 9902 format (' asink = ',256a1)
cbug write ( 3, 9901) nbase, iend, iword, iword, iword
cbug write ( 3, 9902) aquote, (asink(i), i = 1, iend), aquote
cbugc***DEBUG ends.
c.... Test for input errors.
nerr = 0
ibeg = iend + 1
if ((nbase .ne. 8) .and. (nbase .ne. 10) .and.
& (nbase .ne. 16)) then
nerr = 1
go to 210
endif
if (iend .le. 0) then
nerr = 2
go to 210
endif
c.... Start with the absolute value of iword.
if (iword .ge. 0) then
iworn = iword
else
iworn = -iword
endif
c.... Translate iword into ASCII characters in asink.
c---- Loop over characters in asink.
do 120 i = iend, 1, -1
iwork = iworn
iworn = iwork / nbase
idig = iwork - nbase * iworn
c++++ Not a digit.
if ((idig .lt. 0) .or. (idig .gt. (nbase - 1))) then
nerr = 5
ibeg = i + 1
go to 210
endif
asink(i) = adigit(idig)
c---- Do not translate leading zeros.
if (iworn .eq. 0) go to 130
c---- End of loop over characters in asink.
120 continue
c.... The translation will not fit into asink.
c---- More than iend digits.
nerr = 3
ibeg = 1
go to 210
c.... Add a minus sign if iword is negative.
c---- Exactly iend digits.
130 if (i .eq. 1) then
c---- No room for minus sign.
if (iword .lt. 0) then
nerr = 4
endif
else
c---- Put a minus sign into asink.
if (iword .lt. 0) then
i = i - 1
asink(i) = '-'
endif
endif
ibeg = i
210 nchar = iend + 1 - ibeg
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptchia results: ibeg=',i3,' nchar=',i2,' nerr=',i2,
cbug & 2x,a8)
cbug write ( 3, 9903) ibeg, nchar, nerr, abad(nerr)
cbug write ( 3, 9902) aquote, (asink(i), i = 1, iend), aquote
cbugc***DEBUG ends.
return
c.... End of subroutine aptchia. (+1 line.)
end
UCRL-WEB-209832