./42_parser/incomprs.F90

ABINIT/incomprs

ABINIT/incomprs [ Functions ]

NAME

 incomprs

FUNCTION

 Compresses input character string into the following form:
 (1) Replaces tabs and all other characters lexically less than
 SP (blank) with SP (blank), where lexically less than refers to
 the ASCII collating sequence (SP is hex 20, dec 32).
 The use of llt is needed e.g. on the IBM 9000 because it does not
 handle tab characters sensibly in its AIX fortran.
 Also replace occurences of '=' by a SP.
 (2) Removes all repeated blanks, ignoring trailing blanks
 after first (returns nontrailing final length in arg 'length').
 (3) Makes first character in string NONBLANK.  This is done
 to prevent double blanks from occurring when compressed string
 is concatenated with other compressed strings.
 (4) Makes last character (string(length:length)) a blank.
 If input string is entirely blank or tabs, simply returns with length=0.

 Copyright (C) 1998-2017 ABINIT group (DCA, XG).
 This file is distributed under the terms of the
 GNU General Public License, see ~abinit/COPYING
 or http://www.gnu.org/copyleft/gpl.txt .
 For the initials of contributors, see ~abinit/doc/developers/contributors.txt .

INPUTS

  (see side effects)

OUTPUT

  length=nonblank, nontab length of string as defined above

 SIDE EFFECT
  string=at input:  character string
         at output: repeated blanks and tabs have been removed and
                    remaining tabs have been replaced by blanks

PARENTS

      importxyz,instrng

CHILDREN

      inreplsp

SOURCE

 48 #if defined HAVE_CONFIG_H
 49 #include "config.h"
 50 #endif
 51 
 52 #include "abi_common.h"
 53 
 54 
 55 subroutine incomprs(string,length)
 56 
 57  use defs_basis
 58  use m_profiling_abi
 59  use m_errors
 60 
 61 !This section has been created automatically by the script Abilint (TD).
 62 !Do not modify the following lines by hand.
 63 #undef ABI_FUNC
 64 #define ABI_FUNC 'incomprs'
 65  use interfaces_42_parser, except_this_one => incomprs
 66 !End of the abilint section
 67 
 68  implicit none
 69 
 70 !Arguments ------------------------------------
 71 !scalars
 72  integer,intent(out) :: length
 73  character(len=*),intent(inout) :: string
 74 
 75 !Local variables-------------------------------
 76  character(len=1) :: blank=' '
 77 !scalars
 78  integer :: bb,f1,ii,jj,kk,l1,lbef,lcut,lold,stringlen
 79  character(len=500) :: message
 80 
 81 ! *************************************************************************
 82 
 83 !
 84 !String length determined by calling program declaration of "string"
 85  stringlen=len(string)
 86  length=stringlen
 87 !
 88 !Only proceed if string has nonzero length
 89  if (length>0) then
 90 !  Find last nonblank character (i.e. nonblank and nontab length)
 91    length=len_trim(string)
 92    if (length==0) then
 93 !    Line is all blanks or tabs so do not proceed
 94 !    write(std_out,*)' incomprs: blank line encountered'
 95    else
 96 
 97 !    Replace all characters lexically less than SP, and '=', by SP (blank)
 98      call inreplsp(string(1:length))
 99 
100 !    Continue with parsing
101 !    l1 is set to last nonblank, nontab character position
102      l1=length
103      do ii=1,l1
104        if (string(ii:ii)/=blank) exit
105      end do
106 
107 !    f1 is set to first nonblank, nontab character position
108      f1=ii
109 !    lbef is number of characters in string starting at
110 !    first nonblank, nontab and going to last
111      lbef=l1-f1+1
112 
113 !    Process characters one at a time from right to left:
114      bb=0
115      lcut=lbef
116      do ii=1,lbef
117        jj=lbef+f1-ii
118 !      set bb=position of next blank coming in from right
119        if (string(jj:jj)==blank) then
120          if (bb==0) then
121            bb=jj
122          end if
123        else
124          if (bb/=0) then
125 !          if several blanks in a row were found, cut from string
126            if (jj<bb-1) then
127 !            lold becomes string length before cutting blanks
128              lold=lcut
129 !            lcut will be new string length
130              lcut=lcut-(bb-1-jj)
131 !            redefine string with repeated blanks gone
132              do kk=1,f1+lcut-1-jj
133                string(jj+kk:jj+kk)=string(kk+bb-1:kk+bb-1)
134              end do
135            end if
136            bb=0
137          end if
138        end if
139      end do
140 !    
141 !    Remove initial blanks in string if any
142      if (f1>1) then
143        string(1:lcut)=string(f1:f1+lcut-1)
144      end if
145 !    
146 !    Add blank on end unless string had no extra space
147      if (lcut==stringlen) then
148        write(message,'(a,i7,a,a,a,a,a,a,a,a)')&
149 &       'For input file, with data forming a string of',stringlen,' characters,',ch10,&
150 &       'no double blanks or tabs were found.',ch10,&
151 &       'This is unusual for an input file (or any file),',ch10,&
152 &       'and may cause parsing trouble.  Is this a binary file?',ch10
153        MSG_WARNING(message)
154      else
155        length=lcut+1
156        string(length:length)=blank
157      end if
158    end if
159  end if
160 
161 end subroutine incomprs

TABLE OF CONTENTS

ABINIT/incomprs [ Functions ]