subroutine aptsuba (astem, lstem, asub, lsub, nchar, & asink, lsink, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTSUBA c c call aptsuba (astem, lstem, asub, lsub, nchar, c asink, lsink, nerr) c c Version: aptsuba Updated 2004 January 23 13:30. c aptsuba Originated 2004 January 23 13:30. c c Authors: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To store a string astem of length lstem, and if lsub is c positive, a left parenthesis "(", a string asub of length c lsub, and a right parenthesis ")", totaling c lsink = lstem + lsub + 2 characters, in string asink c of length nchar, and right-fill with blanks. c Flag nerr indicates any input error. c c Input: astem, lstem, asub, lsub, nchar. c c Output: asink, lsink, nerr. c c Calls: aptchmv (in ~/work/apt/src on gps01, toofast18llnlgov) c c Glossary: c c asink Output A character string of type character, with a length of c at least nchar > 0. c c astem Input A character string of type character, with a length of c at least lstem > 0. c c asub Input A character string of type character, with a length of c at least lsub => 0. c c lsink Output The number of characters moved into asink, starting at c the first (leftmost) character. c If lsub = 0, lsink = lstem. c If lsub > 0, lsink = lstem + lsub + 2. c Any remaining characters to the right will be filled c with blanks. c c lstem Input The number of characters in astem to be moved into c asink, starting at the first (leftmost) character c of asink. Must be positive. c c lsub Input The number of characters in string asub to be moved c into asink, after astem and, if lsub is positive, c after a left parenthesis "(", and followed by a c right parenthesis ")". Must not be negative. c c nchar Input The number of characters in the string asink. c c nerr Output Indicates an input error, if not zero: c 1 if lstem is not positive. c 2 if lsub is negative. c 3 if nchar is not at least lstem + lsub + 2. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Declarations for arguments. dimension astem (1) ! First string to be stored in asink. character*1 astem ! First string to be stored in asink. dimension asub (1) ! Third string to be stored in asink. character*1 asub ! Third string to be stored in asink. dimension asink (1) ! String with astem, "(", asink, ")". character*1 asink ! String with astem, "(", asink, ")". c.... Local variables. character*1 apar1 ! A left parenthesis. character*1 apar2 ! A right parenthesis. cbugc***DEBUG begins. cbug character*1 aquote ! A quotation mark. cbug aquote = '"' cbug 9901 format (/ 'aptsuba storing astem and asub,' / cbug & 'with lengths lstem =',i4,', lsub =',i4, / cbug & 'into asink, with length nchar =',i4,'.' ) cbug 9902 format ('astem = ',72a1) cbug 9903 format ('asub = ',72a1) cbug write ( 3, 9901) lstem, lsub, nchar cbug write ( 3, 9902) aquote, (astem(n), n = 1, lstem), aquote cbug write ( 3, 9903) aquote, (asub(n), n = 1, lsub), aquote cbugc***DEBUG ends. c.... Initialize. apar1 = "(" apar2 = ")" c.... Fill asink with blanks. if (nchar .gt. 0) then do 110 n = 1, nchar asink(n) = ' ' 110 continue endif c.... Test for input errors. nerr = 0 lsink = 0 if (lstem .le. 0) then nerr = 1 go to 210 endif if (lsub .lt. 0) then nerr = 2 go to 210 endif if (lsub .gt. 0) then lsink = lstem + lsub + 2 else lsink = lstem endif if (nchar .lt. lsink) then nerr = 3 go to 210 endif c.... Put astem into asink. iput = 1 call aptchmv (astem, 1, lstem, asink, iput, nerr) iput = iput + lstem if (lsub .eq. 0) go to 210 call aptchmv (apar1, 1, 1, asink, iput, nerr) iput = iput + 1 call aptchmv (asub, 1, lsub, asink, iput, nerr) iput = iput + lsub call aptchmv (apar2, 1, 1, asink, iput, nerr) 210 continue cbugc***DEBUG begins. cbug 9904 format (/ 'aptsuba results: nerr =',i2,', lsink =',i5) cbug 9905 format ('asink = ',72a1) cbug write ( 3, 9904) nerr, lsink cbug write ( 3, 9905) aquote, (asink(n), n = 1, lsink), aquote cbugc***DEBUG ends. return c.... End of subroutine aptsuba. (+1 line.) end UCRL-WEB-209832