subroutine aptrmbl (nopt, asrce, isrce, nchar, iamax, & asink, isink, lsink, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTRMBL c c call aptrmbl (nopt, asrce, isrce, nchar, iamax, c asink, isink, lsink, nerr) c c Version: aptrmbl Updated 2002 October 25 17:30. c aptrmbl Originated 2002 October 25 17:00. c c Authors: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To remove leading and/or trailing blanks from the input c character string of length nchar, starting at character c position isrce in character string asrce, and return the c result in character string asink. c Flag nerr indicates any input error. c c Input: asrce, isrce, nchar, iamax. c c Output: asink, isink, lsink, nerr. c c Calls: (none) c c Glossary: c c asrce Input A character array of type character, containing an c input string of length nchar, starting in character c position isrce. c c asink Output A character string of type character, of length c lsink (<= iamax), resulting from removal of leading c and/or trailing blanks from the input string. c Initialized to blank characters. c c iamax Input Maximum number of characters for asrce, the input c string and asink. c c isink Output The character position in array asrce of the first c character of the output string asink. c c isrce Input The character position in array asrce of the first c character of the input string. E. g., isrce = 1 c means the leftmost character of asrce. c Must be positive. c c lsink Output The actual number of characters in string asink. c May not exceed iamax. c Zero if no non-blank characters. c c nchar Input The number of characters in the input string. c Must be positive. c c nerr Output Indicates an input error, if not zero. The last error c found is indicated by: c 1 if isrce is not positive. c 2 if nchar is not positive. c 3 if isrce + nchar - 1 exceeds iamax. c 4 if iamax is not positive. c 5 if nopt is < 0 or > 3. c c nopt Input Indicates option: c 0 to remove no blanks. Binary 00. c 1 to remove trailing blanks only. Binary 01. c 2 to remove leading blanks only. Binary 10. c 3 to remove leading and trailing blanks. Binary 11. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Declarations for arguments. dimension asrce(1) ! String containing input string. character*1 asrce ! String containing input string. dimension asink(1) ! Output string. character*1 asink ! Output string. c***DEBUG begins. character*1 aquote aquote = '"' 9901 format (/ 'aptrmbl removing leading and/or trailing blanks.' / & ' nopt =',i2,' isrce =',i3,' nchar =',i3,' iamax =',i3 ) 9902 format (' asrce =',2x,82a1) write ( 3, 9901) nopt, isrce, nchar, iamax if ((nchar .ge. 1) .and. (isrce .ge. 1)) then isink = isrce iend = isrce + nchar - 1 if (isink .gt. iamax) isink = iamax if (iend .gt. iamax) iend = iamax write ( 3, 9902) aquote, (asrce(n), n = isink, iend), aquote endif c***DEBUG ends. c.... Initialize. isink = 0 lsink = 0 do 110 n = 1, iamax asink(n) = ' ' 110 continue c.... Test for input errors. nerr = 0 if (isrce .le. 0) then nerr = 1 go to 210 endif if (nchar .le. 0) then nerr = 2 go to 210 endif if ((isrce + nchar - 1) .gt. iamax) then nerr = 3 go to 210 endif if (iamax .le. 0) then nerr = 4 go to 210 endif if ((nopt .lt. 0) .or. (nopt .gt. 3)) then nerr = 5 go to 210 endif c.... Find the index of the first non-blank character of the string. ibeg1 = isrce iend1 = isrce + nchar - 1 isink = ibeg1 iend = iend1 if ((nopt .eq. 2) .or. (nopt .eq. 3)) then do 115 n = ibeg1, iend1 if (asrce(n) .ne. ' ') then isink = n go to 120 endif 115 continue isink = iend1 + 1 endif c.... Find the index of the last non-blank character of the string. 120 if ((nopt .eq. 1) .or. (nopt .eq. 3)) then do 125 n = iend1, isink, -1 if (asrce(n) .ne. ' ') then iend = n go to 130 endif 125 continue iend = isink - 1 endif 130 continue cbugc***DEBUG begins. cbug 9701 format (' ibeg1 =',i3,' iend1 =',i3,' isink =',i3,' iend =',i3) cbug write ( 3, 9701) ibeg1, iend1, isink, iend cbug write ( 3, 9902) aquote, cbug & (asrce(n), n = isink, iend), aquote cbugc***DEBUG ends. if (iend .lt. isink) then go to 210 endif c.... Store the result in asink. nn = 0 do 140 n = isink, iend nn = nn + 1 asink(nn) = asrce(n) 140 continue lsink = iend - isink + 1 210 continue c***DEBUG begins. 9903 format (/ 'aptrmbl results: isink =',i3,' lsink =',i3, & ' nerr =',i2) 9904 format (' asink =',2x,82a1) write ( 3, 9903) isink, lsink, nerr if (lsink .gt. 0) then write ( 3, 9904) aquote, (asink(nn), nn = 1, lsink), & aquote endif c***DEBUG ends. return c.... End of subroutine aptrmbl. (+1 line.) end UCRL-WEB-209832