subroutine aptsubb (astem, lstem, nsub, asub, lsub, iamax,
& al, as, ar, asink, lsink, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSUBB
c
c call aptsubb (astem, lstem, nsub, asub, lsub, iamax,
c & al, as, ar, asink, lsink, nerr)
c
c Version: aptsubb Updated 2005 March 1 17:20.
c aptsubb Originated 2004 November 17 14:00.
c
c Authors: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To store ASCII stem astem of length lstem, and nsub ASCII
c subscripts asub of length lsub, into an ASCII string asink,
c of initial length iamax, which will initially be blank-filled.
c The first subscript asub(1) will be preceded by character "al",
c and the last subscript asub(nsub) will be followed by character
c "ar". Multiple subscripts will be separated by character "as".
c The final length of asink is returned as lsink.
c Flag nerr indicates any input error.
c
c Input: astem, lstem, nsub, asub, lsub, iamax, al, as, ar.
c
c Output: asink, lsink, nerr.
c
c Calls: aptchmv (in ~/work/apt/src on gps, toofast18llnlgov)
c
c Glossary:
c
c al Input A character placed before the first subscript.
c
c ar Input A character placed after the last subscript.
c
c as Input A character to be placed between adjacent subscripts.
c
c asink Output A character string with an initial length of iamax.
c
c astem Input A character string with a length of lstem > 0.
c The character space for astem must be iamax.
c
c asub Input The ASCII representation of a subscript.
c Array size must be at least nsub.
c The character space for each asub must be iamax.
c
c iamax Input The actual memory space assigned to astem, to each
c asub, and to asink. The latter will initially be
c blank-filled. Must be large enough to contain the
c stem, subscripts and separators.
c
c lsink Output The number of characters moved into asink, starting at
c the first (leftmost) character. Any remaining
c characters to the right, up to a total of iamax.
c will be filled with blanks. Will not exceed iamax.
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, but no more than iamax.
c
c lsub Input The length of string asub, which must be positive, but
c no more than iamax.
c Array size must be at least nsub.
c
c nerr Output Indicates an input error, if not zero:
c 1 if iamax is not positive.
c 2 if lstem is not positive.
c 3 if lstem exceeds iamax.
c 4 if nsub is not positive.
c 5 if any lsub is not positive.
c 6 if any lsub exceeds iamax.
c 7 if iamax is not large enough to contain the
c stem, subscripts and separators.
c
c nsub Input The number of ASCII subscripts asub.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Declarations for arguments.
character*1 al ! Separator to left of first subscript.
character*1 ar ! Separator to right of last subscript.
character*1 as ! Separator between adjacent subscripts.
character*1 asink(1) ! String with stem, subscripts.
character*1 astem(1) ! First string to be stored in asink.
character*1 asub(iamax,1) ! An ASCII subscript.
integer iamax ! The size in memory of asink.
integer nerr ! Error flag.
integer lsink ! The number of characters put into asink.
integer lstem ! The number of characters in astem.
integer lsub(1) ! The number of characters in asub.
integer nsub ! The number of subscripts asub.
cbugc***DEBUG begins.
cbug character*1 aquote ! A quotation mark.
cbug aquote = '"'
cbug 9901 format (/ 'aptsubb storing ASCII stem astem and ASCII',
cbug & ' subscripts', /
cbug & ' asub(n), n = 1, nsub into ASCII word asink, with initial',
cbug & ' length iamax.')
cbug 9902 format ('lstem =',i4,'. astem = ',256a1)
cbug 9903 format ('nsub =',i4,'. iamax = ',i4,'.')
cbug 9904 format ('lsub =',i4,'. ',256a1 )
cbug write ( 3, 9901)
cbug write ( 3, 9902) lstem, aquote, (astem(n), n = 1, lstem), aquote
cbug write ( 3, 9903) nsub, iamax
cbug if (nsub .gt. 0) then
cbug do n = 1, nsub
cbug write ( 3, 9904) lsub(n), aquote,
cbug & (asub(nn,n), nn = 1, lsub(n)), aquote
cbug enddo
cbug endif
cbugc***DEBUG ends.
c.... Initialize.
c.... Fill asink with blanks.
if (iamax .gt. 0) then
do 110 n = 1, iamax
asink(n) = ' '
110 continue
endif
c.... Test for input errors.
nerr = 0
lsink = 0
if (iamax .le. 0) then
nerr = 1
go to 210
endif
if (lstem .le. 0) then
nerr = 2
go to 210
endif
if (lstem .gt. iamax) then
nerr = 3
go to 210
endif
if (nsub .le. 0) then
nerr = 4
go to 210
endif
ltot = lstem + 2 + nsub - 1
do n = 1, nsub
if (lsub(n) .le. 0) then
nerr = 5
go to 210
endif
if (lsub(n) .gt. iamax) then
nerr = 6
go to 210
endif
ltot = ltot + lsub(n)
enddo
if (ltot .gt. iamax) then
nerr = 7
go to 210
endif
c.... Put stem astem into asink.
lsink = 1
call aptchmv (astem, 1, lstem, asink, lsink, nerr)
lsink = lsink + lstem
c.... Put left separator "al" into asink.
call aptchmv (al, 1, 1, asink, lsink, nerr)
lsink = lsink + 1
c.... Put ASCII subscripts into asink, followed by "as".
do n = 1, nsub ! Loop over subscripts.
c.... Move ASCII subscript into asink.
call aptchmv (asub(1,n), 1, lsub(n), asink, lsink, nerra)
lsink = lsink + lsub(n)
c.... Add "as" after subscript.
call aptchmv (as, 1, 1, asink, lsink, nerr)
lsink = lsink + 1
enddo ! End of loop over subscripts.
c.... Replace last "as" with "ar".
lsink = lsink - 1
call aptchmv (ar, 1, 1, asink, lsink, nerr)
210 continue
cbugc***DEBUG begins.
cbug 9905 format (/ 'aptsubb results: nerr =',i2)
cbug 9906 format ('lsink =',i4,'. asink = ',256a1)
cbug write ( 3, 9905) nerr
cbug write ( 3, 9906) lsink, aquote, (asink(n), n = 1, lsink), aquote
cbugc***DEBUG ends.
return
c.... End of subroutine aptsubb. (+1 line.)
end
UCRL-WEB-209832