substitute Subroutine

public subroutine substitute(targetline, old, new, ierr, start, end)

NAME

substitute(3f) - [M_strings:EDITING] subroutine globally substitutes
one substring for another in string
(LICENSE:PD)

SYNOPSIS

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

DESCRIPTION

Globally substitute one substring for another in string.

OPTIONS

 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.

EXAMPLES

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

AUTHOR

John S. Urban

LICENSE

Public Domain

Arguments

Type IntentOptional 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

Contents

Source Code


Source Code

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