subroutine aptblsq (asrce, isrce, nchar, asink, isink, & lsink, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTBLSQ c c call aptblsq (asrce, isrce, nchar, asink, isink, lsink, nerr) c c Version: aptblsq Updated 2006 January 9 16:20. c aptblsq Originated 2005 December 20 16:30. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To remove extra blank characters from a character string. c The string starts at the isrce'th character of asrce, has length c nchar, and will be moved into asink, starting at the isink'th c character of asink. Up to 1024 characters will be moved c correctly if the source and sink locations of the character c string overlap. Flag nerr indicates any input error. c c Input: asrce, isrce, nchar, asink, isink. c c Output: asink, lsink, nerr. c c Glossary: c c asrce Input The array containing a character string, starting at c the isrce'th character, with length nchar, to have c multiple blanks reduced to single blanks, and be c moved into array asink. Size must be at least c isrce + nchar - 1. c c asink In/Out The array receiving the character string, starting at c the isink'th character. Size must be at least c isink + nchar - 1. c c isrce Input The character position in array asrce of the first c character to be tested and moved. E. g., 1 for the c leftmost character of asrce(1). Must be positive. c c isink Input The character position in array asink receiving the c first character to be moved. Must be positive. c c lsink Output The number of characters put into asink, starting a c the isink'th character. c c nchar Input The length of the character string to be tested and c moved. Must be positive. If more than 1024, overlap c of arrays asrce and asink may result in error. c c nerr Output Indicates an input error, if not zero. c 1 if nchar is not positive. c 2 if isrce is not positive. c 3 if isink is not positive. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. character*1 asrce(1) ! Input string. character*1 asink(1) ! Output string. c.... Local variables. integer n ! Index in character string. character*1 abuff(1024) character*1 aquote cbugc***DEBUG begins. cbug integer ncharm cbug integer nmaxa cbug integer nmaxb cbug 9901 format (/ 'aptblsq removing multiple blanks from a', cbug & ' character string.' / cbug & ' isrce=',i6,' nchar=',i6,' isink=',i6) cbug 9902 format (' asrce = ',1002a1) cbug aquote = '"' cbug nmaxa = isrce + nchar - 1 cbug write ( 3, 9901) isrce, nchar, isink cbug write ( 3, 9902) aquote, (asrce(n), n = isrce, nmaxa), aquote 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 if (isink .le. 0) then nerr = 3 go to 210 endif c.... Move the character string from asrce to asink. c.... Use abuff to prevent overstoring. if (nchar .le. 1024) then do n = 1, nchar abuff(n) = ' ' asink(n) = ' ' enddo nout = 1 abuff(nout) = asrce(isrce) do 110 n = 2, nchar if ((asrce(isrce+n-1) .eq. ' ') .and. & (asrce(isrce+n-2) .eq. ' ')) go to 110 nout = nout + 1 abuff(nout) = asrce(isrce+n-1) 110 continue if (abuff(nout) .eq. ' ') then nout = nout - 1 endif lsink = nout do n = 1, lsink asink(isink+n-1) = abuff(n) enddo else ! Make no check for overstoring. cbugcbugc***DEBUG begins. cbugcbug nout = 1 cbugcbug abuff(nout) = asrce(isrce) cbugcbug do 120 n = 2, 1024 cbugcbug if ((asrce(isrce+n-1) .eq. ' ') .and. cbugcbug & (asrce(isrce+n-2) .eq. ' ')) go to 120 cbugcbug nout = nout + 1 cbugcbug abuff(nout) = asrce(isrce+n-1) cbugcbug 120 continue cbugcbug lsink = nout cbugcbug cbugcbug if (abuff(nout) .eq. ' ') then cbugcbug nout = nout - 1 cbugcbug endif cbugcbug cbugcbugc***DEBUG ends. nout = 1 asink(isink+nout-1) = asrce(isrce) do 130 n = 2, 1024 if ((asrce(isrce+n-1) .eq. ' ') .and. & (asrce(isrce+n-2) .eq. ' ')) go to 130 nout = nout + 1 asink(isink+nout-1) = asrce(isrce+n-1) 130 continue if (asink(isink+nout-1) .eq. ' ') then nout = nout - 1 endif lsink = nout endif ! Tested nchar. cbugc***DEBUG begins. cbug 9904 format (/ 'aptblsq results: lsink =',i5,'.') cbug 9905 format (' abuff = ',1024a1) cbug 9906 format (' asink = ',1024a1) cbug write ( 3, 9904) lsink cbug ncharm = min (nchar, 1024) cbug nmaxb = isink + lsink - 1 cbug write ( 3, 9905) aquote, (abuff(n), n = 1, ncharm), aquote cbug write ( 3, 9906) aquote, (asink(n), n = isink, nmaxb), aquote cbugc***DEBUG ends. 210 return c.... End of subroutine aptblsq. (+1 line.) end UCRL-WEB-209832