subroutine aptchmv (asrce, isrce, nchar, asink, isink, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTCHMV
c
c call aptchmv (asrce, isrce, nchar, asink, isink, nerr)
c
c Version: aptchmv Updated 1991 November 18 10:00.
c aptchmv Originated 1991 November 18 10:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To move a character string from array asrce to array asink.
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 1000 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, 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 be
c moved into array asink.
c
c asink In/Out The array receiving the character string, starting at
c the isink'th character.
c
c isrce Input The character position in array asrce of the first
c character to be moved. E. g., 1 for the leftmost
c 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 nchar Input The length of the character string to be moved. Must
c be positive. If more than 1000, overlap of arrays
c 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.
c---- Source of character string.
dimension asrce (1)
c---- Source of character string.
character asrce*1
c---- Sink for character string.
dimension asink (1)
c---- Sink for character string.
character asink*1
c.... Local variables.
c---- Character string buffer.
common /captchmv/ cbuff(1000)
c---- Character string buffer.
character cbuff*1
character*1 aquote
c---- Index in character string.
common /laptchmv/ n
cbugc***DEBUG begins.
cbugc---- Minimum of nchar, 1000.
cbug common /laptchmv/ ncharm
cbugc---- Number of character of asrce to write.
cbug common /laptchmv/ nmaxa
cbugc---- Number of character of asink to write.
cbug common /laptchmv/ nmaxb
cbug 9901 format (/ 'aptchmv moving a character string.' /
cbug & ' isrce=',i6,' nchar=',i6,' isink=',i6)
cbug 9902 format (' asrce = ',256a1)
cbug 9903 format (' asink = ',256a1)
cbug aquote = '"'
cbug write ( 3, 9901) isrce, nchar, isink
cbug nmaxa = 8 * (1 + (isrce + nchar - 2) / 8)
cbug write ( 3, 9902) aquote, (asrce(n), n = 1, nmaxa), aquote
cbug nmaxb = 8 * (1 + (isink + nchar - 2) / 8)
cbug write ( 3, 9903) aquote, (asink(n), n = 1, nmaxb), 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 cbuff to prevent overstoring.
if (nchar .le. 1000) then
do 110 n = 1, nchar
cbuff(n) = asrce(isrce +n-1)
110 continue
do 120 n = 1, nchar
asink(isink+n-1) = cbuff(n)
120 continue
c---- Make no check for overstoring.
else
cbugc***DEBUG begins.
cbug do 123 n = 1, 1000
cbug cbuff(n) = asrce(isrce +n-1)
cbug 123 continue
cbugc***DEBUG ends.
do 130 n = 1, nchar
asink(isink+n-1) = asrce(isrce +n-1)
130 continue
c---- Tested nchar.
endif
cbugc***DEBUG begins.
cbug 9904 format (/ 'aptchmv results:')
cbug 9905 format (' cbuff = ',256a1)
cbug write ( 3, 9904)
cbug ncharm = min0 (nchar, 1000)
cbug write ( 3, 9905) aquote, (cbuff(n), n = 1, ncharm), aquote
cbug write ( 3, 9903) aquote, (asink(n), n = 1, nmaxb), aquote
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptchmv. (+1 line.)
end
UCRL-WEB-209832