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