subroutine aptchrn (kset, asrce, isrce, nchar, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTCHRN c c call aptchrn (kset, asrce, isrce, nchar, nerr) c c Version: aptchrn Updated 1991 December 7 9:30. c aptchrn Originated 1991 December 7 9:30. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To put random characters, from a list determined by kset, c into a character string in asrce, starting at character c position isrce in asrce, and with length nchar. c Flag nerr indicates any input error. c c Input: kset, asrce, isrce, nchar. c c Output: asrce, nerr. c c Glossary: c c asrce In/Out A type character word or array, containing at least c isrce + nchar - 1 characters. Character positions c are counted to the right, from 1 at the leftmost c character. Characters in positions from isrce to c isrce + nchar - 1 will be replaced by randomly c selected characters. c c isrce Input The character position in array asrce of the first c character to be replaced. Must be positive. c c kset Input Indicates the group of characters from which random c characters will be selected. Must be from 1 to 7. c 1 for lower case a-z. c 2 for upper case A-Z. c 4 for numerals 0-9. c Any sum of 1, 2, and 4 for combinations. c c nchar Input The length of the character string to be replaced. c Must be positive. c c nerr Output Indicates an input error, if not zero. c 1 if kset is not in the range 1-7. c 2 if isrce is not positive. c 3 if nchar is not positive. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. c---- Array containing character string. dimension asrce (1) c---- Array containing character string. character asrce*1 c.... Local variables. c---- Characters to be randomly selected. dimension achar (72) c---- Characters to be randomly selected. character*1 achar data achar / '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', & 'a', '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', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', & 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', & 'U', 'V', 'W', 'X', 'Y', 'Z' , & '1', '2', '3', '4', '5', '6', '7', '8', '9', '0' / c---- Lowest index in subset of achar. common /laptchrn/ ibeg c---- Randomly sampled index in achar. common /laptchrn/ ichar c---- Highest index in subset of achar. common /laptchrn/ iend c---- Index in character string. common /laptchrn/ n c---- Number of random characters in subset. common /laptchrn/ nset cbugc***DEBUG begins. cbugc---- Number of character of asrce to write. cbug common /laptchrn/ nmaxa cbug 9901 format (/ 'aptchrn putting random characters in a string.' / cbug & ' kset=',i2,' isrce=',i6,' nchar=',i6) cbug 9902 format (' asrce=',64a1) cbug write ( 3, 9901) kset, isrce, nchar cbug nmaxa = 8 * (1 + (isrce + nchar - 2) / 8) cbug write ( 3, 9902) (asrce(n), n = 1, nmaxa) cbugc***DEBUG ends. c.... initialize. nerr = 0 c.... Test for input errors. if ((kset .lt. 1) .or. (kset .gt. 7)) then nerr = 1 go to 210 endif if (isrce .le. 0) then nerr = 2 go to 210 endif if (nchar .le. 0) then nerr = 3 go to 210 endif c.... Choose the character set to be randomly sampled. c---- Characters a-z. if (kset .eq. 1) then ibeg = 11 iend = 36 c---- Characters A-Z. elseif (kset. eq. 2) then ibeg = 37 iend = 62 c---- Characters a-z, A-Z. elseif (kset .eq. 3) then ibeg = 11 iend = 62 c---- Characters 0-9. elseif (kset. eq. 4) then ibeg = 1 iend = 10 c---- Characters a-z, 0-9. elseif (kset. eq. 5) then ibeg = 1 iend = 36 c---- Characters A-Z, 0-9. elseif (kset. eq. 6) then ibeg = 37 iend = 72 c---- Characters a-z, A-Z, 0-9. elseif (kset. eq. 7) then ibeg = 1 iend = 62 c---- Tested kset. endif nset = iend - ibeg + 1 c.... Put random characters from achar into asrce(isrce) to c.... asrce(isrce +nchar-1). do 110 n = isrce, isrce + nchar - 1 ichar = ibeg + ranf( ) * nset asrce(n) = achar(ichar) 110 continue 210 continue cbugc***DEBUG begins. cbug 9905 format (/ 'aptchrn results: nerr=',i3) cbug write ( 3, 9905) nerr cbug write ( 3, 9902) (asrce(n), n = 1, nmaxa) cbugc***DEBUG ends. return c.... End of subroutine aptchrn. (+1 line.) end UCRL-WEB-209832