subroutine aptchin (nadd, asrce, isrce, nchar, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTCHIN c c call aptchin (nadd, asrce, isrce, nchar, nerr) c c Version: aptchin Updated 2003 June 30 16:00. c aptchin Originated 1991 November 21 18:00. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To increment (nadd > 0) or decrement (nadd < 0) any numeric c or alphabetic (lower or upper case) characters in array asrce, c in the character string starting at character position isrce in c asrce, of length nchar. The procedure begins at the rightmost c character of the string, and carries to the left, if necessary, c ignoring any blank, non-numeric, or non-alphabetic characters. c In any character positions, numbers remain numbers, and case c does not change. Flag nerr indicates any input error, or c failure to properly alter the character string. c c Examples: Incrementing "a9.9" results in "b0.0". Decrementing "1.A" c results in "0.Z". Incrementing "+++" fails, with nerr = 3. c Decrementing "3 A " results in "2 Z ". Decrementing "aaa" c results in "zzz", with nerr = 4. c c Input: nadd, asrce, isrce, nchar. c c Output: asrce, nerr. c c Glossary: c c asrce In/Out An array containing a character string. c c isrce Input The character position in array asrce of the first c character of the string. E. g., isrce = 1 means c the leftmost character of asrce(1). c Must be positive. c c nadd Input Indicates the number of times (absolute value) the c character string should be incremented (positive) c or decremented (negative). Zero for no change. c c nchar Input The length of the character string. Must be positive. c c nerr Output Indicates an input or result error, if not zero. c 1 if nchar is not positive. c 2 if isrce is not positive. c 3 if the character string can not be altered. c 4 if the leftmost required carry can not be done. c Stops processing immediately, regardless of nadd. c c Changes: 1993 March 16 15:40. Corrected bug in decrementing, that c affected any decrement through "1", "b", or "B". c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. dimension asrce (1) ! Array containing character string. character asrce*1 ! Array containing character string. c.... Local variables. character*1 aschar (65) ! Array of ASCII numbers and letters. c.... Note positions of 9, 0, z, a, Z, A, and repeat of 1, b, B. data aschar / & '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', '1', & 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', & 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', & 'x', 'y', 'z', 'a', 'b', & 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', & 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', & 'X', 'Y', 'Z', 'A', 'B' / common /laptchin/ idir ! Incrementing (+1) or decrementing (-1). common /laptchin/ na ! Count from 1 to nadda. common /laptchin/ nadda ! Absolute value of nadd. common /laptchin/ nbeg ! Starting index in aschar. common /laptchin/ nc ! Index in character string. common /laptchin/ nd ! Index in aschar. common /laptchin/ nd1 ! Initial search index. common /laptchin/ nd2 ! Final search index. cbugc*** DEBUG begins. cbugc.... Number of character of asrce to write. cbug common /laptchin/ nmaxa cbug 9901 format (/ 'aptchin incrementing or decrementing ASCII.' / cbug & ' nadd=',i3,' isrce=',i6,' nchar=',i6) cbug 9902 format (' asrce=',64a1) cbug write ( 3, 9901) nadd, isrce, nchar cbug nmaxa = 8 * (1 + (isrce + nchar - 2) / 8) cbug write ( 3, 9902) (asrce(nc), nc = 1, nmaxa) cbugc*** DEBUG ends. c.... initialize. nerr = 0 c.... Test for input errors. if (nchar .le. 0) then nerr = 1 go to 210 endif if (isrce .le. 0) then nerr = 2 go to 210 endif c.... Find out if incrementing or decrementing. if (nadd .eq. 0) then ! No change required. go to 210 elseif (nadd .gt. 0) then ! Incrementing. nbeg = 1 idir = 1 nadda = nadd nd1 = nbeg nd2 = nbeg + 63 else ! Decrementing. nbeg = 2 idir = -1 nadda = -nadd nd1 = nbeg + 63 nd2 = nbeg endif c.... Process the character string abs (nadd) times. do 130 na = 1, nadda ! Loop over string processing. nerr = 3 ! No change yet. c.... Process (increment or decrement) character string from right to c.... left (from asrce(isrce +nchar-1) to asrce(isrce)). do 120 nc = nchar, 1, -1 ! Loop over string characters. c.... Test for match between string character and ASCII character. do 110 nd = nd1, nd2, idir ! Loop over ASCII characters. if (asrce(isrce +nc-1) .eq. aschar(nd)) then ! Found match. nerr = 0 ! Changed character. asrce(isrce +nc-1) = aschar(nd+idir) ! Increment or decrement. if ((nd .eq. (nbeg + 8)) .or. & (nd .eq. (nbeg + 35)) .or. & (nd .eq. (nbeg + 62))) then nerr = 4 ! No carry yet. go to 120 ! Requires carry to left. endif go to 130 ! No carry required. endif ! Tested character. 110 continue ! End of loop over ASCII characters. 120 continue ! End of loop over string characters. if (nerr .ne. 0) go to 210 ! Process failed. 130 continue ! End of loop over string processing. 210 continue cbugc*** DEBUG begins. cbug 9905 format (/ 'aptchin results: nerr=',i2) cbug write ( 3, 9905) nerr cbug write ( 3, 9902) (asrce(nc), nc = 1, nmaxa) cbugc*** DEBUG ends. return c.... End of subroutine aptchin. (+1 line.) end UCRL-WEB-209832