1 | !**************************************************************
|
---|
2 | !
|
---|
3 | ! This file contains the subroutines: extstr,ibegst,iendst,
|
---|
4 | ! iredin,iredrl,iopfil,
|
---|
5 | ! tolost,toupst
|
---|
6 | !
|
---|
7 | ! Copyright 2003-2005 Frank Eisenmenger, U.H.E. Hansmann,
|
---|
8 | ! Shura Hayryan, Chin-Ku
|
---|
9 | ! Copyright 2007 Frank Eisenmenger, U.H.E. Hansmann,
|
---|
10 | ! Jan H. Meinke, Sandipan Mohanty
|
---|
11 | !
|
---|
12 | ! **************************************************************
|
---|
13 |
|
---|
14 |
|
---|
15 | subroutine extstr(spr,ib,ie,str,strn,l)
|
---|
16 |
|
---|
17 | ! ..........................................................
|
---|
18 | ! PURPOSE: Extract substring preceeding separator 'spr'
|
---|
19 | ! from 'str' searching from position 'ib' up to
|
---|
20 | ! position 'ie' and put it into 'strn(1:l)'.
|
---|
21 | ! 'ib' is shifted to position following 'spr' or
|
---|
22 | ! to 'ie+1', if 'spr' is not found
|
---|
23 | !
|
---|
24 | ! ! 'spr' should not be blank
|
---|
25 | !
|
---|
26 | ! CALLS: ibegst,iendst
|
---|
27 | ! ..........................................................
|
---|
28 | integer ib, ie, l
|
---|
29 | integer ln, is, ibegst, j, iendst
|
---|
30 |
|
---|
31 | character spr,blnk,str*(*),strn*(*)
|
---|
32 |
|
---|
33 | data blnk/' '/
|
---|
34 |
|
---|
35 | integer i, ic, ish, ii
|
---|
36 |
|
---|
37 | if (spr.eq.blnk) then
|
---|
38 | write (*,*) ' extstr> Separator should not be blank'
|
---|
39 | stop
|
---|
40 | endif
|
---|
41 |
|
---|
42 | l=0
|
---|
43 | ln=len(strn)
|
---|
44 | strn=blnk
|
---|
45 | is=index(str(ib:ie),spr) ! position of spr
|
---|
46 |
|
---|
47 | if (is.lt.1) then ! _________ no separator
|
---|
48 |
|
---|
49 | l=ie-ib+1
|
---|
50 | if (ln.lt.l) goto 1
|
---|
51 | strn(1:l)=str(ib:ie)
|
---|
52 | ib=ie+1
|
---|
53 | elseif (is.eq.1) then ! _________ empty substring
|
---|
54 | ib=ib+1
|
---|
55 | return
|
---|
56 | else ! _________ found separator
|
---|
57 | l=is-1
|
---|
58 | if (ln.lt.l) goto 1
|
---|
59 | strn(1:l)=str(ib:ib+l-1)
|
---|
60 | ib=ib+is
|
---|
61 | endif
|
---|
62 |
|
---|
63 | i=ibegst(strn)
|
---|
64 |
|
---|
65 | if (i.lt.1) then ! empty substring
|
---|
66 |
|
---|
67 | l=0
|
---|
68 | strn=blnk
|
---|
69 | ! ____________________________ make string in 'strn' left justified
|
---|
70 | elseif (i.gt.1) then
|
---|
71 | j=iendst(strn)
|
---|
72 | l=j-i+1
|
---|
73 | strn(1:l)=strn(i:j)
|
---|
74 | strn(l+1:ln)=blnk
|
---|
75 | else
|
---|
76 | l=iendst(strn)
|
---|
77 | endif
|
---|
78 |
|
---|
79 | return
|
---|
80 | ! ______________________________________________________________ Error
|
---|
81 | 1 write (*,'(a)') ' extstr> Substring to be extracted is too long !'
|
---|
82 | stop
|
---|
83 |
|
---|
84 | end
|
---|
85 | ! **********************************
|
---|
86 | integer*4 function ibegst(str)
|
---|
87 |
|
---|
88 | ! .............................................................
|
---|
89 | ! PURPOSE: returns position of 1st non-blank character in 'str'
|
---|
90 | !
|
---|
91 | ! CALLS: none
|
---|
92 | !
|
---|
93 | ! .............................................................
|
---|
94 |
|
---|
95 | implicit none
|
---|
96 | integer i
|
---|
97 | character blnk,str*(*)
|
---|
98 | data blnk/' '/
|
---|
99 |
|
---|
100 | do i=1,len(str)
|
---|
101 | if (str(i:i).ne.blnk) then
|
---|
102 | ibegst=i
|
---|
103 | return
|
---|
104 | endif
|
---|
105 | enddo
|
---|
106 |
|
---|
107 | ibegst=0
|
---|
108 |
|
---|
109 | return
|
---|
110 | end
|
---|
111 | ! **********************************
|
---|
112 | integer*4 function iendst(str)
|
---|
113 |
|
---|
114 | ! ..............................................................
|
---|
115 | ! PURPOSE: returns position of last non-blank character in 'str'
|
---|
116 | !
|
---|
117 | ! CALLS: none
|
---|
118 | !
|
---|
119 | ! ..............................................................
|
---|
120 |
|
---|
121 | implicit none
|
---|
122 | integer i
|
---|
123 | character blnk,str*(*)
|
---|
124 | data blnk/' '/
|
---|
125 |
|
---|
126 | do i=len(str),1,-1
|
---|
127 | if (str(i:i).ne.blnk) then
|
---|
128 | iendst=i
|
---|
129 | return
|
---|
130 | endif
|
---|
131 | enddo
|
---|
132 |
|
---|
133 | iendst=0
|
---|
134 |
|
---|
135 | return
|
---|
136 | end
|
---|
137 | ! **************************************
|
---|
138 | integer*4 function iredin(line,in)
|
---|
139 |
|
---|
140 | ! ..........................................
|
---|
141 | ! PURPOSE: Read integer*4 value 'in' from 'line'
|
---|
142 | ! with format 'i9'
|
---|
143 | !
|
---|
144 | ! iredin=0 : error status
|
---|
145 | ! iredin=1 : success
|
---|
146 | !
|
---|
147 | ! CALLS: ibegst,iendst
|
---|
148 | ! ..........................................
|
---|
149 |
|
---|
150 | implicit none
|
---|
151 | integer mxd, ib, ibegst, ie, iendst, il, i0, i9, i, ii, in
|
---|
152 | parameter (mxd=9) ! max. # of digits
|
---|
153 |
|
---|
154 | character blnk,value*(mxd),line*(*)
|
---|
155 | data blnk/' '/
|
---|
156 |
|
---|
157 | iredin=0
|
---|
158 | ib=ibegst(line)
|
---|
159 | if (ib.gt.0) then
|
---|
160 | ie=iendst(line)
|
---|
161 | il=ie-ib
|
---|
162 | if (il.lt.mxd) then
|
---|
163 | i0=ichar('0')
|
---|
164 | i9=ichar('9')
|
---|
165 | do i=ib,ie
|
---|
166 | ii=ichar(line(i:i))
|
---|
167 | if (ii.lt.i0.or.ii.gt.i9) goto 1
|
---|
168 | enddo
|
---|
169 | value=blnk
|
---|
170 | value(mxd-il:mxd)=line(ib:ie)
|
---|
171 | read(value,'(i9)',err=1) in
|
---|
172 | iredin=1
|
---|
173 | endif
|
---|
174 | endif
|
---|
175 | 1 return
|
---|
176 | end
|
---|
177 | ! *************************************
|
---|
178 | integer*4 function iredrl(line,r)
|
---|
179 |
|
---|
180 | ! ..........................................
|
---|
181 | ! PURPOSE: Read real*8 value 'r' from 'line'
|
---|
182 | ! with format 'd17.6'
|
---|
183 | !
|
---|
184 | ! iredrl=0 : error status
|
---|
185 | ! iredrl=1 : success
|
---|
186 | !
|
---|
187 | ! CALLS: ibegst,iendst
|
---|
188 | ! ..........................................
|
---|
189 |
|
---|
190 | implicit none
|
---|
191 | integer mxd, mxap, mxip, ib, ibegst, ie, iendst, il, ip, ibp
|
---|
192 | parameter (mxd =17, ! max. # of digits
|
---|
193 | & mxap= 6, ! max. # of digits after period
|
---|
194 | & mxip=mxd-mxap)
|
---|
195 |
|
---|
196 | real*8 r
|
---|
197 | character per,blnk,value*(mxd),line*(*)
|
---|
198 | data per/'.'/,blnk/' '/
|
---|
199 |
|
---|
200 | iredrl=0
|
---|
201 |
|
---|
202 | ib=ibegst(line)
|
---|
203 | if (ib.gt.0) then
|
---|
204 | ie=iendst(line)
|
---|
205 | if (index(line(ib:ie),',').gt.0) return
|
---|
206 | il=ie-ib+1
|
---|
207 | ip=index(line,per)
|
---|
208 | value=blnk
|
---|
209 | if (ip.gt.0) then ! found period
|
---|
210 | ibp=ip-ib
|
---|
211 | if (il.le.mxd.and.ibp.lt.mxip.and.ie-ip.le.mxap) then
|
---|
212 | value(mxip-ibp:)=line(ib:ie)
|
---|
213 | read (value,'(d17.6)',err=1) r
|
---|
214 | iredrl=1
|
---|
215 | endif
|
---|
216 | else ! no period
|
---|
217 | if (il.lt.mxip) then
|
---|
218 | value(mxip-il:)=line(ib:ie)//per
|
---|
219 | read (value,'(d17.6)',err=1) r
|
---|
220 | iredrl=1
|
---|
221 | endif
|
---|
222 | endif
|
---|
223 | endif
|
---|
224 |
|
---|
225 | 1 return
|
---|
226 | end
|
---|
227 | ! **************************
|
---|
228 | subroutine tolost(str)
|
---|
229 |
|
---|
230 | ! ..........................................
|
---|
231 | ! PURPOSE: converts 'string' to lower-case
|
---|
232 | ! INPUT: str - string to be converted
|
---|
233 | ! CALLS: ibegst,iendst
|
---|
234 | ! ..........................................
|
---|
235 |
|
---|
236 | include 'INCL.H'
|
---|
237 |
|
---|
238 | character*(*) str
|
---|
239 |
|
---|
240 | integer ibegst, iendst
|
---|
241 |
|
---|
242 | integer i, ic, ii, ish
|
---|
243 | ii=ibegst(str)
|
---|
244 | if (ii.gt.0) then
|
---|
245 | ish=idupa-idloa
|
---|
246 | do i=ii,iendst(str)
|
---|
247 | ic=ichar(str(i:i))
|
---|
248 | if (ic.ge.idupa.and.ic.le.idupz) str(i:i)=char(ic-ish)
|
---|
249 | enddo
|
---|
250 | endif
|
---|
251 |
|
---|
252 | return
|
---|
253 | end
|
---|
254 | ! **************************
|
---|
255 | subroutine toupst(str)
|
---|
256 |
|
---|
257 | ! ..........................................
|
---|
258 | ! PURPOSE: converts 'string' to upper-case
|
---|
259 | ! INPUT: str - string to be converted
|
---|
260 | ! CALLS: ibegst,iendst
|
---|
261 | ! ..........................................
|
---|
262 |
|
---|
263 | include 'INCL.H'
|
---|
264 |
|
---|
265 | character str*(*)
|
---|
266 |
|
---|
267 | integer iendst, ibegst
|
---|
268 |
|
---|
269 | integer i, ii, ic, ish
|
---|
270 |
|
---|
271 | ii=ibegst(str)
|
---|
272 | if (ii.gt.0) then
|
---|
273 | ish=idupa-idloa
|
---|
274 | do i=ii,iendst(str)
|
---|
275 | ic=ichar(str(i:i))
|
---|
276 | if (ic.ge.idloa.and.ic.le.idloz) str(i:i)=char(ic+ish)
|
---|
277 | enddo
|
---|
278 | endif
|
---|
279 |
|
---|
280 | return
|
---|
281 | end
|
---|
282 | ! *****************************************************
|
---|
283 | integer*4 function iopfil(lun,filnam,stat,format)
|
---|
284 |
|
---|
285 | ! ........................................................
|
---|
286 | ! PURPOSE: open 'lun' with 'filnam' 'stat' 'format'
|
---|
287 | !
|
---|
288 | ! returns: 1 = file successful opened
|
---|
289 | ! 0 = error during open of existing file
|
---|
290 | ! -1 = file does not exist
|
---|
291 | !
|
---|
292 | ! CALLS: ibegst
|
---|
293 | ! ........................................................
|
---|
294 |
|
---|
295 | integer lun
|
---|
296 | integer i, ibegst, j, k
|
---|
297 | logical exs
|
---|
298 | character*(*) filnam,stat,format
|
---|
299 |
|
---|
300 | iopfil=0
|
---|
301 |
|
---|
302 | if (lun.gt.0.and.lun.lt.100) then
|
---|
303 | i=ibegst(filnam)
|
---|
304 | if (i.gt.0) then
|
---|
305 | inquire(file=filnam(i:),exist=exs)
|
---|
306 | if (exs) then
|
---|
307 | j=ibegst(stat)
|
---|
308 | k=ibegst(format)
|
---|
309 | if (j.gt.0.and.k.gt.0) then
|
---|
310 | open(lun,file=filnam(i:),status=stat(j:),
|
---|
311 | & form=format(k:),err=1)
|
---|
312 | iopfil=1
|
---|
313 | endif
|
---|
314 | else
|
---|
315 | iopfil=-1
|
---|
316 | endif
|
---|
317 | endif
|
---|
318 | endif
|
---|
319 |
|
---|
320 | 1 return
|
---|
321 | end
|
---|
322 |
|
---|