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