subroutine aptsubi (astem, lstem, nsub, isub, iamax,
& al, as, ar, asink, lsink, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSUBI
c
c call aptsubi (astem, lstem, nsub, isub, iamax,
c & al, as, ar, asink, lsink, nerr)
c
c Version: aptsubi Updated 2005 March 1 17:20.
c aptsubi Originated 2005 March 1 17:20.
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 integer
c subscripts isub into an ASCII string asink, of initial length
c iamax, which will initially be blank-filled.
c The first subscript isub(1) will be preceded by character "al",
c and the last subscript isub(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, isub, 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 iamax Input The actual memory space assigned to astem and asink.
c The latter will initially be blank-filled.
c Must be large enough to contain the stem, subscripts
c and separators.
c
c isub Input The integer value of a subscript.
c Array size must be at least nsub.
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 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 negative.
c 5 if nsub exceeds 16.
c 6 if iamax is not large enough to contain the
c stem, subscripts and separators.
c
c nsub Input The number of integer subscripts isub.
c May not exceed 16.
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.
integer iamax ! The size in memory of astem and asink.
integer nerr ! Error flag.
integer lsink ! The number of characters put into asink.
integer lstem ! The number of characters in astem.
integer nsub ! The number of subscripts isub.
integer isub(1) ! The integer subscripts.
c.... Local variables.
character*1 asub(iamax,16) ! An ASCII subscript.
dimension lsub(16) ! Length of ASCII subscript.
character*80 asubx ! Right-adjusted ASCII subscript.
cbugc***DEBUG begins.
cbug character*1 aquote ! A quotation mark.
cbug aquote = '"'
cbug 9901 format (/ 'aptsubi storing ASCII stem astem and integer',
cbug & ' subscripts', /
cbug & ' isub(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 ('n =',i4,'. isub(n) =',i6)
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 write ( 3, 9904) (n, isub(n), n = 1, nsub)
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 .lt. 0) then
nerr = 4
go to 210
endif
if (nsub .gt. 16) then
nerr = 5
go to 210
endif
ltot = lstem + 2 + nsub - 1
do n = 1, nsub
ltot = ltot + lsub(n)
enddo
if (ltot .gt. iamax) then
nerr = 6
go to 210
endif
c.... Put stem astem into asink.
lsink = 1
call aptchmv (astem, 1, lstem, asink, lsink, nerr)
if (nsub .eq. 0) go to 210
c.... Put left separator "al" into asink.
lsink = lsink + lstem
call aptchmv (al, 1, 1, asink, lsink, nerr)
c.... Put ASCII subscripts into asink, followed by "as".
lsink = lsink + 1
do n = 1, nsub ! Loop over subscripts.
c.... Find ASCII equivalent of subscript, put into asub.
asubx = ' '
call aptchia (isub(n), 10, asubx, iamax, ibeg, lsub(n), nerr)
nchar = 1
call aptchmv (asubx, ibeg, lsub(n), asub(1,n), nchar, nerr)
c.... Move ASCII subscript into asink.
call aptchmv (asub(1,n), 1, lsub(n), asink, lsink, nerra)
c.... Add "as" after subscript.
lsink = lsink + lsub(n)
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 (/ 'aptsubi 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 aptsubi. (+1 line.)
end
UCRL-WEB-209832