substitute(3f) - [M_strings:EDITING] subroutine globally substitutes
one substring for another in string
(LICENSE:PD)
subroutine substitute(targetline,old,new,ierr,start,end)
character(len=*) :: targetline
character(len=*),intent(in) :: old
character(len=*),intent(in) :: new
integer,intent(out),optional :: ierr
integer,intent(in),optional :: start
integer,intent(in),optional :: end
Globally substitute one substring for another in string.
TARGETLINE input line to be changed. Must be long enough to
hold altered output.
OLD substring to find and replace
NEW replacement for OLD substring
IERR error code. If IER = -1 bad directive, >= 0 then
count of changes made.
START sets the left margin to be scanned for OLD in
TARGETLINE.
END sets the right margin to be scanned for OLD in
TARGETLINE.
Sample Program:
program demo_substitute
use M_strings, only : substitute
implicit none
! must be long enough to hold changed line
character(len=80) :: targetline
targetline='this is the input string'
write(*,*)'ORIGINAL : '//trim(targetline)
! changes the input to 'THis is THe input string'
call substitute(targetline,'th','TH')
write(*,*)'th => TH : '//trim(targetline)
! a null old substring means "at beginning of line"
! changes the input to 'BEFORE:this is the input string'
call substitute(targetline,'','BEFORE:')
write(*,*)'"" => BEFORE: '//trim(targetline)
! a null new string deletes occurrences of the old substring
! changes the input to 'ths s the nput strng'
call substitute(targetline,'i','')
write(*,*)'i => "" : '//trim(targetline)
end program demo_substitute
Expected output
ORIGINAL : this is the input string
th => TH : THis is THe input string
"" => BEFORE: BEFORE:THis is THe input string
i => "" : BEFORE:THs s THe nput strng
John S. Urban
Public Domain
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| character(len=*) | :: | targetline | ||||
| character(len=*), | intent(in) | :: | old | |||
| character(len=*), | intent(in) | :: | new | |||
| integer, | intent(out), | optional | :: | ierr | ||
| integer, | intent(in), | optional | :: | start | ||
| integer, | intent(in), | optional | :: | end |
subroutine substitute(targetline,old,new,ierr,start,end)
! ident_12="@(#) M_strings substitute(3f) Globally substitute one substring for another in string"
!-----------------------------------------------------------------------------------------------------------------------------------
character(len=*) :: targetline ! input line to be changed
character(len=*),intent(in) :: old ! old substring to replace
character(len=*),intent(in) :: new ! new substring
integer,intent(out),optional :: ierr ! error code. if ierr = -1 bad directive, >=0 then ierr changes made
integer,intent(in),optional :: start ! start sets the left margin
integer,intent(in),optional :: end ! end sets the right margin
!-----------------------------------------------------------------------------------------------------------------------------------
character(len=len(targetline)) :: dum1 ! scratch string buffers
integer :: ml, mr, ier1
integer :: maxlengthout ! MAXIMUM LENGTH ALLOWED FOR NEW STRING
integer :: original_input_length
integer :: len_old, len_new
integer :: ladd
integer :: ir
integer :: ind
integer :: il
integer :: id
integer :: ic
integer :: ichr
!-----------------------------------------------------------------------------------------------------------------------------------
if (present(start)) then ! optional starting column
ml=start
else
ml=1
endif
if (present(end)) then ! optional ending column
mr=end
else
mr=len(targetline)
endif
!-----------------------------------------------------------------------------------------------------------------------------------
ier1=0 ! initialize error flag/change count
maxlengthout=len(targetline) ! max length of output string
original_input_length=len_trim(targetline) ! get non-blank length of input line
dum1(:)=' ' ! initialize string to build output in
id=mr-ml ! check for window option ! change to optional parameter(s)
!-----------------------------------------------------------------------------------------------------------------------------------
len_old=len(old) ! length of old substring to be replaced
len_new=len(new) ! length of new substring to replace old substring
if(id <= 0)then ! no window so change entire input string
il=1 ! il is left margin of window to change
ir=maxlengthout ! ir is right margin of window to change
dum1(:)=' ' ! begin with a blank line
else ! if window is set
il=ml ! use left margin
ir=min0(mr,maxlengthout) ! use right margin or rightmost
dum1=targetline(:il-1) ! begin with what's below margin
endif ! end of window settings
!-----------------------------------------------------------------------------------------------------------------------------------
if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin)
ichr=len_new + original_input_length
if(ichr > maxlengthout)then
call journal('sc','*substitute* new line will be too long')
ier1=-1
if (present(ierr))ierr=ier1
return
endif
if(len_new > 0)then
dum1(il:)=new(:len_new)//targetline(il:original_input_length)
else
dum1(il:)=targetline(il:original_input_length)
endif
targetline(1:maxlengthout)=dum1(:maxlengthout)
ier1=1 ! made one change. actually, c/// should maybe return 0
if(present(ierr))ierr=ier1
return
endif
!-----------------------------------------------------------------------------------------------------------------------------------
ichr=il ! place to put characters into output string
ic=il ! place looking at in input string
loop: do
ind=index(targetline(ic:),old(:len_old))+ic-1 ! try to find start of old string in remaining part of input in change window
if(ind == ic-1.or.ind > ir)then ! did not find old string or found old string past edit window
exit loop ! no more changes left to make
endif
ier1=ier1+1 ! found an old string to change, so increment count of changes
if(ind > ic)then ! if found old string past at current position in input string copy unchanged
ladd=ind-ic ! find length of character range to copy as-is from input to output
if(ichr-1+ladd > maxlengthout)then
ier1=-1
exit loop
endif
dum1(ichr:)=targetline(ic:ind-1)
ichr=ichr+ladd
endif
if(ichr-1+len_new > maxlengthout)then
ier1=-2
exit loop
endif
if(len_new /= 0)then
dum1(ichr:)=new(:len_new)
ichr=ichr+len_new
endif
ic=ind+len_old
enddo loop
!-----------------------------------------------------------------------------------------------------------------------------------
select case (ier1)
case (:-1)
call journal('sc','*substitute* new line will be too long')
case (0) ! there were no changes made to the window
case default
ladd=original_input_length-ic
if(ichr+ladd > maxlengthout)then
call journal('sc','*substitute* new line will be too long')
ier1=-1
if(present(ierr))ierr=ier1
return
endif
if(ic < len(targetline))then
dum1(ichr:)=targetline(ic:max(ic,original_input_length))
endif
targetline=dum1(:maxlengthout)
end select
if(present(ierr))ierr=ier1
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine substitute