1 integer function getlin(ieq) 2 character*137 line 3 common /rdwr/ iun1,iun2,iun3,iun4,iun5 4 common /curlin/ line 5 common /mflin/ linmf 6 7 getlin = 1 8 9 call nxtlin(line,jstat) 10 if (jstat.eq.1.or.jstat.eq.2) goto 100 11 12 linmf = linmf + 1 13 do i=1,137 14 if (ichar(line(i:i)).eq.9) line(i:i) = ' ' 15 end do 16 17 if (ieq.eq.1.or.ieq.eq.2) then 18 do i=1,137 19 if (ichar(line(i:i)).eq.61) line(i:i) = ' ' 20 end do 21 endif 22 23 if (ieq.eq.2) then 24 do i=1,137 25 ii = ichar(line(i:i)) 26 if (ii.eq.40.or.ii.eq.41.or.ii.eq.34.or.ii.eq.39) 27 & line(i:i) = ' ' 28 end do 29 endif 30 31 if (ieq.eq.3) then 32 do while (.true.) 33 i1 = index(line,'(') 34 i2 = index(line,')') 35 if (i1.gt.0.and.i2.gt.0) then 36 line = line(1:i1-1)//line(i2+1:) 37 else 38 return 39 endif 40 end do 41 endif 42 43 return 44100 getlin = 0 45 return 46 end 47 48 subroutine setlin(str,ic) 49 character*(*) str 50 character*137 line 51 common /curlin/ line 52 53 line = str 54 if (ic.ne.0) then 55 do i=1,linlen(str) 56 if (ichar(line(i:i)).eq.ic) line(i:i) = ' ' 57 end do 58 endif 59 60 return 61 end 62 63 integer function nxtwrd(string,strlen,itype,rtype) 64c 65c string nxtwrd = 1 66c integer nxtwrd = 2 67c real nxtwrd = 3 68c no word nxtwrd = 0 69c 70 character*(*) string 71 integer itype,strlen 72 double precision rtype 73 double precision reada 74 logical chkstr 75 character*137 line 76 common /curlin/ line 77 78 nxtwrd = 0 79 80 llen = linlen(line) 81 if (llen.eq.0) return 82 83 do while (line(1:1).eq.' ') 84 line = line(2:) 85 end do 86 87 iend = index(line,' ') 88 if (iend.eq.0) then 89 iend = llen 90 else 91 iend = iend - 1 92 endif 93 if (chkstr(line,iend)) then 94 nxtwrd = 1 95 string = line(1:iend) 96 strlen = iend 97 elseif (index(line(1:iend),'.').ne.0) then 98 nxtwrd = 3 99 rtype = reada(line,1,iend) 100 else 101 nxtwrd = 2 102 itype = reada(line,1,iend) 103 endif 104 105 line = line(iend+1:) 106 107 return 108 end 109 110 integer function nxtwrz(string,strlen,itype,rtype) 111c 112c string nxtwrd = 1 113c integer nxtwrd = 2 114c real nxtwrd = 3 115c n*int nxtwrd = 4 116c no word nxtwrd = 0 117c 118 character*(*) string 119 integer itype,strlen 120 double precision rtype 121 double precision reada 122 logical chkstd 123 character*137 line 124 common /curlin/ line 125 126 nxtwrz = 0 127 128 llen = linlen(line) 129 if (llen.eq.0) return 130 131 do while (line(1:1).eq.' ') 132 line = line(2:) 133 end do 134 135 iend = index(line,' ') 136 if (iend.eq.0) then 137 iend = llen 138 else 139 iend = iend - 1 140 endif 141 if (chkstd(line,iend)) then 142 nxtwrz = 1 143 string = line(1:iend) 144 strlen = iend 145 elseif (index(line(1:iend),'.').ne.0) then 146 if (index(line(1:iend),'*').ne.0) then 147 ied = index(line,'*') 148 if (ied.eq.0) then 149 ied = llen 150 else 151 ied = ied - 1 152 endif 153 itype = reada(line,1,ied) 154 nxtwrz = 4 155 else 156 nxtwrz = 3 157 rtype = reada(line,1,iend) 158 endif 159 else 160 nxtwrz = 2 161 itype = reada(line,1,iend) 162 endif 163 164 line = line(iend+1:) 165 166 return 167 end 168 169 integer function nxtwrx(string,strlen,itype,rtype) 170c 171c string nxtwrd = 1 172c integer nxtwrd = 2 173c real nxtwrd = 3 174c no word nxtwrd = 0 175c 176 character*(*) string 177 integer itype,strlen 178 double precision rtype 179 double precision reada 180 logical chkstr 181 character*137 line 182 common /curlin/ line 183 184 nxtwrx = 0 185 186 nine = ichar('9') 187 izero = ichar('0') 188 189 llen = linlen(line) 190 if (llen.eq.0) return 191 192 do while (line(1:1).eq.' ') 193 line = line(2:) 194 end do 195 196 if (llen.gt.3) then 197 do i=1,llen-2 198 ii = ichar(line(i+1:i+1)) 199 if (line(i:i).eq.'('.and.line(i+2:i+2).eq.')'.and. 200 & (ii.ge.izero.and.ii.le.nine)) then 201 line = line(i-1:)//line(i+3:) 202 endif 203 end do 204 endif 205 206 llen = linlen(line) 207 if (llen.eq.0) return 208 209 iend = index(line,' ') 210 if (iend.eq.0) then 211 iend = llen 212 else 213 iend = iend - 1 214 endif 215 216 if (chkstr(line,iend)) then 217 nxtwrx = 1 218 string = line(1:iend) 219 strlen = iend 220 elseif (index(line(1:iend),'.').ne.0) then 221 nxtwrx = 3 222 rtype = reada(line,1,iend) 223 else 224 nxtwrx = 2 225 itype = reada(line,1,iend) 226 endif 227 228 line = line(iend+1:) 229 230 return 231 end 232 233 logical function chkstr(line,iend) 234 character*(*) line 235 chkstr = .false. 236 237 ie = ichar('e') 238 iee = ichar('E') 239 id = ichar('d') 240 idd = ichar('D') 241 nine = ichar('9') 242 izero = ichar('0') 243 minus = ichar('-') 244 iplus = ichar('+') 245 idot = ichar('.') 246 icomma = ichar(',') 247 islash = ichar('/') 248 249 ihase = 0 250 idig = 0 251 do i=1,iend 252 n = ichar(line(i:i)) 253 if ((n.eq.ie.or.n.eq.iee.or.n.eq.id.or.n.eq.idd) 254 & .and.ihase.eq.0.and.idig.eq.1) then 255 n = izero 256 ihase = 1 257 endif 258 if (n.lt.iplus.or.n.gt.nine.or.n.eq.islash 259 & .or.n.eq.icomma) goto 100 260 idig = 1 261 end do 262 263 n = ichar(line(1:1)) 264 n2 = ichar(line(2:2)) 265 if (iend.eq.1) then 266 if (n.eq.minus) goto 100 267 if (n.eq.iplus) goto 100 268 if (n.eq.ie.or.n.eq.iee) goto 100 269 if (n.eq.id.or.n.eq.idd) goto 100 270 elseif (iend.gt.1) then 271 if (n.eq.minus.and.n2.eq.minus) goto 100 272 endif 273 274 return 275100 chkstr = .true. 276 return 277 end 278 279 logical function chkstd(line,iend) 280 character*(*) line 281 chkstd = .false. 282 283 ie = ichar('e') 284 iee = ichar('E') 285 id = ichar('d') 286 idd = ichar('D') 287 nine = ichar('9') 288 izero = ichar('0') 289 minus = ichar('-') 290 iplus = ichar('+') 291 idot = ichar('.') 292 icomma = ichar(',') 293 islash = ichar('/') 294 istar = ichar('*') 295 296 ihase = 0 297 idig = 0 298 do i=1,iend 299 n = ichar(line(i:i)) 300 if ((n.eq.ie.or.n.eq.iee.or.n.eq.id.or.n.eq.idd) 301 & .and.ihase.eq.0.and.idig.eq.1) then 302 n = izero 303 ihase = 1 304 endif 305 if ((n.lt.iplus.or.n.gt.nine.or.n.eq.islash 306 & .or.n.eq.icomma).and.n.ne.istar) goto 100 307 idig = 1 308 end do 309 310 n = ichar(line(1:1)) 311 n2 = ichar(line(2:2)) 312 if (iend.eq.1) then 313 if (n.eq.minus) goto 100 314 if (n.eq.iplus) goto 100 315 if (n.eq.ie.or.n.eq.iee) goto 100 316 if (n.eq.id.or.n.eq.idd) goto 100 317 elseif (iend.gt.1) then 318 if (n.eq.minus.and.n2.eq.minus) goto 100 319 endif 320 321 return 322100 chkstd = .true. 323 return 324 end 325 326 integer function linlen(line) 327 character*(*) line 328 integer i,n 329 330 linlen = 0 331 332 do i=len(line),1,-1 333 n = ichar(line(i:i)) 334 if (n.gt.32.and.n.le.126) goto 100 335 end do 336 337 return 338100 linlen = i 339 return 340 end 341 342 logical function dat3ln(lin) 343 integer i,itype,ktype,nstr 344 double precision rtype 345 character*(*) lin 346 character*137 str 347 character*137 line 348 common /curlin/ line 349 350 dat3ln = .true. 351 352 line = lin 353 354 do i=1,3 355 ktype = nxtwrd(str,nstr,itype,rtype) 356 if (ktype.ne.3.and.ktype.ne.2) goto 100 357 end do 358 359 return 360100 dat3ln = .false. 361 return 362 end 363 364 logical function datlin(line) 365 character*(*) line 366 367 datlin = .true. 368 369 do i=1,linlen(line) 370 n = ichar(line(i:i)) 371 if ((n.lt.43.or.n.gt.57).and.n.ne.32.and.n.ne.68. 372 & and.n.ne.100.and.n.ne.69.and.n.ne.101) goto 100 373 end do 374 375 return 376100 datlin = .false. 377 return 378 end 379 380 logical function gnreal(r,n,doget) 381 implicit double precision (a-h,o-z) 382 character*137 line,str 383 common /curlin/ line 384 integer getlin 385 logical doget 386 dimension r(*) 387 388 gnreal = .true. 389 390 if (doget) then 391 if (getlin(0).ne.1) gnreal = .false. 392 endif 393 394 if (gnreal) then 395 do i=1,n 396 ktype = nxtwrd(str,nstr,itype,rtype) 397 if (ktype.eq.3) then 398 r(i) = rtype 399 elseif (ktype.eq.2) then 400 r(i) = dble(itype) 401 else 402 gnreal = .false. 403 endif 404 end do 405 endif 406 407 return 408 end 409 410 logical function gnint(iarr,n,doget) 411 implicit double precision (a-h,o-z) 412 character*137 line,str 413 common /curlin/ line 414 integer getlin 415 logical doget 416 dimension iarr(*) 417 418 gnint = .true. 419 420 if (doget) then 421 if (getlin(0).ne.1) gnint = .false. 422 endif 423 424 425 if (gnint) then 426 do i=1,n 427 ktype = nxtwrd(str,nstr,itype,rtype) 428 if (ktype.eq.2) then 429 iarr(i) = itype 430 else 431 gnint = .false. 432 endif 433 end do 434 endif 435 436 return 437 end 438 439 subroutine lsparm(str,l) 440 character*(*) str 441 442 l = len(str) 443 do i=1,l 444 if (str(i:i).ne.' ') goto 10 445 end do 44610 str = str(i:) 447 l = linlen(str) 448 return 449 end 450 451 subroutine spatrm(str,l) 452 character*(*) str 453 454 j = 1 455 l = len(str) 456 do while (j.le.l) 457 if (str(j:j).eq.' ') then 458 if (l.eq.1) then 459 return 460 else 461 if (j.ne.l) then 462 if (j.eq.1) then 463 str(1:l-1) = str(2:l) 464 str(l:l) = ' ' 465 else 466c str(j:l-1) = str(j:j-1)//str(j+1:l) 467 str(j:l-1) = str(j+1:l) 468 str(l:l) = ' ' 469 endif 470 endif 471 l = l - 1 472 endif 473 else 474 j = j + 1 475 endif 476 end do 477 478c if (l.lt.len(str)) str(l+1:l+1) = char(0) 479 480 return 481 end 482 483 integer function krnd(r) 484 implicit double precision (a-h,p-z),integer (i-n),logical (o) 485 486 krnd = int(r) 487 if (r-dfloat(krnd).ge.0.5d0) krnd = krnd + 1 488 489 return 490 end 491 492 subroutine rmnull(line) 493 implicit double precision (a-h,p-z),integer (i-n),logical (o) 494 character*137 line 495 496 ii = 0 497 do while (ii.le.137) 498 ii = ii + 1 499 jj = ichar(line(ii:ii)) 500 if (jj.eq.0) then 501 do kk=ii,136 502 line(kk:kk) = line(kk+1:kk+1) 503 end do 504 if (ii.eq.138) return 505 ii = ii - 1 506 endif 507 if (jj.eq.10.or.jj.eq.13) return 508 end do 509 510 return 511 end 512 513 subroutine rwfile() 514 implicit double precision (a-h,p-z),integer (i-n),logical (o) 515 common /rdwr/ iun1,iun2,iun3,iun4,iun5 516 517 rewind iun2 518 519 return 520 end 521 522 subroutine bcfile() 523 implicit double precision (a-h,p-z),integer (i-n),logical (o) 524 common /rdwr/ iun1,iun2,iun3,iun4,iun5 525 526 backspace iun2 527 528 return 529 end 530 531 subroutine nxline(line,istat) 532 implicit double precision (a-h,p-z),integer (i-n),logical (o) 533 character*137 line 534 common /rdwr/ iun1,iun2,iun3,iun4,iun5 535 536 istat = 0 537 538 read(iun2,'(a)',end=100,err=200) line 539 540 return 541100 istat = 1 542 return 543200 istat = 2 544 return 545 end 546 547