1 subroutine rdgadd(idebug,ibefo,istatio,irtype,ihsend, 2 & istats,vectrs,vectrb,focc,focb,eiga,eigb, 3 & nocc,nocb,ncols,ncolb) 4 5c THIS IS REALLY rdgamu 6 7 implicit double precision (a-h,o-z), integer (i-n) 8 parameter (numatm=2000) 9 common /moldat/ natoms, norbs, nelecs, nat(numatm) 10 common /coord / xyz(3,numatm) 11 common /orbhlp/ mxorb,iuhf,ispd 12 common /rdwr/ iun1,iun2,iun3,iun4,iun5 13 character*137 line 14 real eiga,eigb 15 dimension vectrs(*),vectrb(*),focc(*),focb(*),eiga(*),eigb(*) 16 parameter (one=1.0d+00, two=2.0d+00) 17 18 i0 = 0 19 i1 = 1 20 i2 = 2 21 istats = 1 22 istatio = 0 23 iuhf = 0 24 25 if (idebug.eq.1) write(iun3,'(a)')'subroutine rdgamu' 26 27c 28c==== Read # of basis functions, electrons 29c 30C** call search(line,'NUMBER OF BASIS FUNCTIONS',istat) 31c.. New GAMESS can handle both cartesian and polar coords 32c.. However, it prints eigenvectors in terms of 6d 33c.. 34 call searchd(line,'NUMBER OF CARTESIAN GAUSSIAN BASIS', 35 & 'NUMBER OF BASIS FUNCTIONS',istat) 36 if (istat.eq.1) then 37 if (icdex(line,'CARTESIAN GAUSSIAN').ne.0) then 38c 39c This is a new version of GAMESS. Lines are wider 40c 41 read(line,'(47x,i5)') norbs 42 call search(line,'NUMBER OF ELECTRONS',istat) 43 read(line,'(47x,i5)') nelecs 44 call search(line,'NUMBER OF OCCUPIED ORBITALS (ALPHA',istat) 45 read(line,'(47x,i5)') nalpha 46c write(*,*) ' ... nalpha = ',nalpha 47 call search(line,'NUMBER OF OCCUPIED ORBITALS (BETA ',istat) 48 read(line,'(47x,i5)') nbeta 49c write(*,*) ' ... nbeta = ',nbeta 50 read(line,'(47x,i5)') nbeta 51 52c ... check if PP used 53 call search(line,'PP =',istat) 54c write(*,*) line(9:12) 55 if (line(9:12).eq.'NONE') then 56 is_pp=0 57 else 58 is_pp=1 59 endif 60 61c ... read PP valence electrons 62 if (is_pp.eq.1) then 63 call search(line,'NUMBER OF ELECTRONS KEPT IN THE ',istat) 64 read(line,'(50x,i4)') nelecs 65 call redel(line,1) 66 read(line,'(50x,i4)') nalpha 67 call redel(line,1) 68 read(line,'(50x,i4)') nbeta 69c write(*,*) nelecs,nalpha,nbeta 70 endif 71c 72c======= Occupy Orbitals - just in case, done here 73c 74 do i=1,norbs 75 focc(i) = 0.0d0 76 end do 77 78 if (nalpha.eq.nbeta) then 79 80 do mel=1,nalpha 81 focc(mel) = two 82 end do 83 84 else 85 86 do mel=1,nalpha 87 focc(mel) = one 88 end do 89 90 do mel=1,nbeta 91 focb(mel) = one 92 end do 93 94 endif 95 else 96c 97c.. Old GAMESS (Pre-Jan10 2000) 98c 99 read(line,'(38x,i5)') norbs 100 call nxtlin(line,jstat) 101 read(line,'(38x,i5)') nelecs 102 103 do i=1,norbs 104 focc(i) = 0.0d0 105 focb(i) = 0.0d0 106 end do 107 108 endif 109 endif 110 call rewfil 111 112 if (norbs .gt. mxorb) then 113 call inferr('Exceeding MaxNum of Orbitals!',1) 114 goto 1000 115 endif 116 117c==== Establish Scftype and Runtype ==== 118 119 irtype = 1 120 121 call search(line,'CONTRL OPTIONS',istat) 122 call search(line,'SCFTYP=',istat) 123 if (index(line,'UHF').ne.0) iuhf=1 124c call search(line,'RUNTYP=',istat) 125 if (index(line,'HESSIAN').ne.0) irtype=4 126 127 call search(line,'STATIONARY POINT LOCATION RUN',istat) 128 if (istat.eq.1) then 129 call search(line,'HSSEND =',istat) 130 if (istat.eq.1) then 131 if (index(line,' T').ne.0) then 132 if (ihsend.eq.1) then 133 irtype=4 134 else 135 call inferr( 136 & 'Use commandlineflag -H for normal modes',0) 137 endif 138 endif 139 endif 140 call search(line,'EQUILIBRIUM GEOMETRY LOCATED',istat) 141 if (istat.eq.1) istatio = 1 142 if (irtype.ne.4) irtype = 2 143 endif 144 145 call rewfil 146c 147c==== First read coordinates, and vectors 148c 149 if (istatio.eq.1.and.ibefo.eq.0) then 150c 151c ====== Stationary Point ================ 152c 153 call search(line,'EQUILIBRIUM GEOMETRY LOCATED',istat) 154 155 call rdmolu(i1,i2,i0,i1,istat) 156 call searcht(line,'MOLECULAR ORBITALS', 157 & '-MCHF- NATURAL ORBITALS', 158 & 'MCSCF NATURAL ORBITALS',istat) 159c & 'NATURAL ORBITALS IN ATOMIC', istat) 160 if (iuhf.eq.1) then 161 call redel(line,3) 162 else 163 call redel(line,1) 164 endif 165 call rdvecu(vectrs,eiga,focc,norbs,ncols,istats,.false., 166 & .false.) 167 168 if (iuhf.eq.1) then 169 call bckfil 170 call bckfil 171 call bckfil 172 call search(line,'BETA SET',istat) 173 call rdvecu(vectrb,eigb,focc,norbs,ncolb,istats,.false., 174 & .false.) 175 endif 176 177 call inferr('Using Density of stationary point',0) 178 179 else 180c 181c ====== First Point =========== 182c 183 call rdmolu(i2,i1,i0,i0,istat) 184c STRIPPED a space character because PC-UNIX output misses first column 185c call searcht(line,' EIGENVECTORS', 186 call searcht(line,' EIGENVECTORS', 187 & '-MCHF- NATURAL ORBITALS', 188 & 'MCSCF NATURAL ORBITALS',istat) 189c & 'NATURAL ORBITALS IN ATOMIC',istat) 190 call redel(line,1) 191 call rdvecu(vectrs,eiga,focc,norbs,ncols,istats,.false., 192 & .false.) 193 if (iuhf.eq.1) then 194 call bckfil 195 call bckfil 196c call search(line,' EIGENVECTORS',istat) 197 call search(line,' EIGENVECTORS',istat) 198 call redel(line,1) 199 call rdvecu(vectrb,eigb,focc,norbs,ncolb,istats,.false., 200 & .false.) 201 endif 202 call inferr('Using Density of first point',0) 203 204 endif 205 206 call rewfil 207c 208c======= Read Basis Set =========== 209c 210c mdebug=idebug 211c idebug=1 212 call rdbasg(idebug,.true.,istat) 213c idebug=mdebug 214 215 if (istat.eq.0) goto 1000 216 217 call search(line,'MULLIKEN AND LOWDIN POPULATION ANALYSES', 218 & istat) 219 220c Alpha 221 222 call search(line,'MULLIKEN ATOMIC POPULATION',istat) 223 if (iuhf.eq.1) call redel(line,1) 224 call rdpopu(focc,natoms,istats) 225 226c Beta 227 228 if (iuhf.eq.1) then 229 call rewfil 230 call search(line,'MULLIKEN ATOMIC POPULATION',istat) 231 call search(line,'MULLIKEN ATOMIC POPULATION',istat) 232 call redel(line,1) 233 call rdpopu(focb,natoms,istats) 234 endif 235 236 call xyzcoo(1,0,0) 237 238c>>> Added Pipek-Mezey and Edmiston-Ruedenberg FPA 3/15/2000 239 240 call rewfil 241 call searcht(line,'BOYS ORBITAL LOCALIZATION', 242 & 'LOCALIZED BY THE POPULATION', 243 & 'EDMISTON-RUEDENBERG',istat) 244 if (istat.ne.0) then 245 246 if (index(line,'BOYS ORBITAL LOCALIZATION').ne.0) then 247 print*,'***** READING BOYS LOCALIZED ORBITALS *****' 248 call search(line,'THE BOYS LOCALIZED ORBITALS ARE', 249 & istat) 250 call rdvecu(vectrs,eiga,focc,norbs,ncols,istats,.true., 251 & .false.) 252 253 if (iuhf.eq.1) then 254 call search(line,'THE BOYS LOCALIZED ORBITALS ARE', 255 & istat) 256 call rdvecu(vectrb,eigb,focc,norbs,ncolb,istats,.true., 257 & .false.) 258 endif 259 260 elseif (index(line,'LOCALIZED BY THE POPULATION').ne.0) then 261 262 print*, 263 & '***** READING Pipek-Mezey LOCALIZED ORBITALS *****' 264 call search(line,'POPULATION LOCALIZED ORBITALS ARE', 265 & istat) 266 call rdvecu(vectrs,eiga,focc,norbs,ncols,istats,.true., 267 & .false.) 268 269 if (iuhf.eq.1) then 270 call search(line,'POPULATION LOCALIZED ORBITALS ARE', 271 & istat) 272 call rdvecu(vectrb,eigb,focc,norbs,ncolb,istats,.true., 273 & .false.) 274 endif 275 276 elseif (index(line,'EDMISTON-RUEDENBERG').ne.0) then 277 278 print*, 279 & '** READING Edmiston-Ruedenberg LOCALIZED ORBITALS**' 280 call search(line,'ENERGY LOCALIZED ORBITALS',istat) 281 call rdvecu(vectrs,eiga,focc,norbs,ncols,istats,.true., 282 & .false.) 283 284 if (iuhf.eq.1) then 285 call search(line,'ENERGY LOCALIZED ORBITALS',istat) 286 call rdvecu(vectrb,eigb,focc,norbs,ncolb,istats,.true., 287 & .false.) 288 endif 289 endif 290 291c no orbital energies associated with localised orbitals 292 293 do i=1,norbs 294 eiga(i) = 0.0e0 295 eigb(i) = 0.0e0 296 end do 297 298 endif 299 300c-------- Try for GUGA Natural Orbitals 301 302 call rewfil 303 call search(line,'NATURAL ORBITALS IN ATOMIC',istat) 304 if (istat.ne.0) then 305 call rdvecu(vectrs,eiga,focc,norbs,ncols,istats,.false., 306 & .true.) 307c no orbital energies associated with localised orbitals 308 309 do i=1,norbs 310 eiga(i) = 0.0e0 311 eigb(i) = 0.0e0 312 end do 313 314 endif 315 316 call rewfil 317c call gamunmr 318 319 return 320 3211000 istats = 0 322 call inferr('ERROR reading GAMESS output file!',1) 323 return 324 end 325 326 subroutine rdvecu(v,e,focc,norbs,ncol,istats,boys,nos) 327 implicit double precision (a-h,o-z), integer ( i-n) 328 parameter (mxcol=10) 329 common /rdwr/ iun1,iun2,iun3,iun4,iun5 330 common /curlin/ line 331 common /orbhlp/ mxorb,iuhf,ispd 332 character*137 line,str 333 integer getlin 334 real e 335 logical boys,reo,nos 336 dimension v(*), e(*), focc(*) 337 dimension vt(6,mxcol),irord(6) 338c 339c====== read vectors ================== 340c 341 istats = 1 342 343 reo = .false. 344 irord(1) = 3 345 irord(2) = 1 346 irord(3) = 2 347 irord(4) = 5 348 irord(5) = 6 349 irord(6) = 4 350 351 lmin = 0 352 do while (.true.) 353 354 if (boys) then 355 call redel(line,1) 356 else 357 if (nos) then 358 call redel(line,3) 359 else 360 call redel(line,2) 361 endif 362 endif 363 364c 365c Get Eigenvalues 366c 367 if (getlin(0).ne.1) goto 1000 368 if (linlen(line).le.1) then 369 if (getlin(0).ne.1) goto 1000 370 endif 371 nc = 0 372 do i=1,mxcol 373 ktype = nxtwrd(str,nstr,itype,rtype) 374 if (ktype.eq.0) goto 5 375 if (ktype.eq.3) then 376 nc = nc + 1 377 if (nos) then 378 focc(lmin+i) = rtype 379 else 380 e(lmin+i) = rtype 381 endif 382 elseif (ktype.eq.2.and.boys) then 383 nc = nc + 1 384 else 385 goto 100 386 endif 387 end do 388 3895 continue 390 call redel(line,1) 391 392c 393c Get Eigenvectors 394c 395 istrt = 0 396 itel = 0 397 398 do j=1,norbs 399 400 if (getlin(0).ne.1) goto 1000 401 ktype = nxtwrd(str,nstr,itype,rtype) 402 if (ktype.ne.2) goto 100 403 ktype = nxtwrd(str,nstr,itype,rtype) 404 if (ktype.ne.1) goto 100 405 ktype = nxtwrd(str,nstr,itype,rtype) 406 if (ktype.ne.1.and.ktype.ne.2) goto 100 407 if (ktype.eq.2) then 408 ktype = nxtwrd(str,nstr,itype,rtype) 409 if (ktype.ne.1) goto 100 410 endif 411 if (istrt.eq.0.and.nstr.eq.3) then 412 if (str(1:3).eq.'XXY') then 413 istrt = j 414 itel = 0 415 reo = .true. 416 endif 417 endif 418 419 do i=1,mxcol 420 ktype = nxtwrd(str,nstr,itype,rtype) 421 if (ktype.eq.0) goto 10 422 if (ktype.ne.3) goto 100 423 v((lmin+i-1)*mxorb+j) = rtype 424 end do 425 42610 continue 427 428 if (istrt.ne.0) then 429 itel = itel + 1 430 do k=1,nc 431 vt(itel,k) = v((lmin+k-1)*mxorb+j) 432 end do 433 endif 434 435 if (itel.eq.6) then 436 do l=1,6 437 do k=1,nc 438 v((lmin+k-1)*mxorb + (istrt+l-1)) = vt(irord(l),k) 439 end do 440 end do 441 istrt = 0 442 itel = 0 443 endif 444 445 end do 446 447 lmin = lmin + nc 448 end do 449 450100 continue 451 ncol = lmin 452 453 if (reo) then 454 print*,'========================================' 455 print*,'Changed order of F functions:' 456 print*,' ' 457 print*,'xxy,xxz,yyx,yyz,zzx,zzy ->' 458 print*,'xyy,xxy,xxz,xzz,yzz,yyz' 459 print*,'========================================' 460 endif 461 462 return 463 4641000 istats = 0 465 call inferr('ERROR reading vectors!',1) 466 return 467 end 468 469 subroutine rdpopu(focc,natoms,istats) 470 implicit double precision (a-h,o-z), integer ( i-n) 471 parameter (mxcol=10) 472 common /rdwr/ iun1,iun2,iun3,iun4,iun5 473 common /curlin/ line 474 character*137 line,str 475 integer getlin 476 dimension focc(*) 477c 478c====== read populations ================== 479c 480 istats = 1 481 482 483 lmin = 0 484 do while (.true.) 485 486 call redel(line,3) 487 488c 489c Get Populations 490c 491 if (getlin(0).ne.1) goto 1000 492 nc = 0 493 do i=1,mxcol 494 ktype = nxtwrd(str,nstr,itype,rtype) 495 if (ktype.eq.0) goto 5 496 if (ktype.ne.3) goto 100 497 nc = nc + 1 498 focc(lmin+i) = rtype 499 end do 500 5015 continue 502 call redel(line,1) 503 504c 505c Dummy reads 506c 507 do j=1,natoms 508 509 if (getlin(0).ne.1) goto 1000 510 511 end do 512 513 lmin = lmin + nc 514 end do 515 516100 continue 517 ncol = lmin 518 519 return 520 5211000 istats = 0 522 call inferr('ERROR reading Populations!',1) 523 return 524 end 525 526 subroutine rdmodu(ilino,iemlin,idocoo,idobohr,istats, 527 & coo,ianz) 528 implicit double precision (a-h,o-z), integer ( i-n) 529 parameter (numatm=2000) 530 common /moldat/ natoms, norbs, nelecs, nat(numatm) 531 common /coord / xyz(3,numatm) 532 common /athlp/ iatoms, mxnat 533 common /rdwr/ iun1,iun2,iun3,iun4,iun5 534 common /curlin/ line 535 character*137 line,str 536 integer getlin 537 dimension coo(3,*),ianz(*) 538c 539c====== read molecular geometry ================== 540c 541c sline = search this line first 542c iemlin = then skip this many lines 543c 544 istats = 1 545 toang = 0.52917706d0 546 547 if (ilino.eq.1) then 548 call search(line, 549 & 'COORDINATES OF ALL ATOMS ARE (ANGS)',istat) 550 elseif (ilino.eq.2) then 551 call search(line, 552 & 'ATOM ATOMIC COORDINATES', 553 & istat) 554 endif 555 556 if (istat.eq.0) goto 1000 557 call redel(line,iemlin) 558 559 if (idocoo.eq.1) then 560 iatoms = 0 561 else 562 natoms = 0 563 endif 564 565 do while (getlin(0).eq.1) 566 if (linlen(line).le.1) return 567 if (index(line,'......').ne.0) return 568 if (idocoo.eq.1) then 569 iatoms = iatoms + 1 570 else 571 natoms = natoms + 1 572 endif 573 ktype = nxtwrd(str,nstr,itype,rtype) 574 if (ktype.gt.2) goto 1000 575 ktype = nxtwrd(str,nstr,itype,rtype) 576 if (ktype.ne.3) goto 1000 577 if (idocoo.eq.1) then 578 ianz(iatoms) = rtype 579 else 580 nat(natoms) = rtype 581 endif 582 do i=1,3 583 ktype = nxtwrd(str,nstr,itype,rtype) 584 if (ktype.ne.3) goto 1000 585 if (idobohr.eq.1) rtype = rtype / toang 586 if (idocoo.eq.1) then 587 coo(i,iatoms) = rtype 588 else 589 xyz(i,natoms) = rtype 590 endif 591 end do 592 end do 593 5941000 istats = 0 595 call inferr('ERROR reading molecular geometry!',1) 596 return 597 end 598 599 subroutine gamupd(ipnt,istat,coo,ianz) 600 implicit double precision (a-h,p-w),integer (i-n),logical (o) 601 parameter (maxfat=1000) 602 real fxyz,fc 603 common /forcom/fxyz(3,maxfat),fc(3,maxfat) 604 common /athlp/ iatoms, mxnat 605 common /gammus/iold 606 607 integer getlin 608 logical getzmu,usnew 609 common /rdwr/ iun1,iun2,iun3,iun4,iun5 610 character*137 line,str 611 common /curlin/ line 612 dimension coo(3,*),ianz(*) 613 614 i0 = 0 615 i1 = 1 616 i2 = 2 617c 618c Read Next Point in geometry optimization 619c 620 toang=0.52917706d0 621 iatoms = 0 622 jatoms = 0 623 usnew = .false. 624 625 if (iold.eq.1) then 626 if (ipnt.eq.1) then 627 call searchd(line, 628 & 'ATOM ATOMIC COORDINATES', 629 & 'GRADIENT (HARTREE/BOHR)',istat) 630 else 631 call searchd(line,'COORDINATES OF ALL ATOMS ARE (ANGS)', 632 & 'GRADIENT (HARTREE/BOHR)',istat) 633 endif 634 635 if (index(line,'ALL ATOMS').ne.0.or. 636 & index(line,'ATOM ATOMIC').ne.0) then 637 call bckfil 638 if (ipnt.eq.1) then 639 call rdmolu(i2,i1,i1,i0,istat) 640 else 641 call rdmolu(i1,i2,i1,i1,istat) 642 endif 643 call search(line,'GRADIENT (HARTREE/BOHR)',istat) 644 endif 645 if (istat.eq.0) return 646 call haszm(.false.) 647 else 648 if (ipnt.eq.1) then 649 call searcht(line, 650 & 'ATOM ATOMIC COORDINATES', 651 & 'GRADIENT (HARTREE/BOHR)', 652 & 'CURRENT FULLY SUBSTITUTED Z-MATRIX',istat) 653 else 654 call searcht(line,'COORDINATES OF ALL ATOMS ARE (ANGS)', 655 & 'GRADIENT (HARTREE/BOHR)', 656 & 'CURRENT FULLY SUBSTITUTED Z-MATRIX',istat) 657 endif 658 if (istat.eq.0) return 659 660 if (index(line,'ALL ATOMS').ne.0.or. 661 & index(line,'ATOMIC').ne.0) then 662 call bckfil 663 if (ipnt.eq.1) then 664 call rdmolu(i2,i1,i1,i0,istat) 665 else 666 call rdmolu(i1,i2,i1,i1,istat) 667 endif 668 call searchd(line,'GRADIENT (HARTREE/BOHR)', 669 & 'CURRENT FULLY SUBSTITUTED Z-MATRIX',istat) 670 if (istat.eq.0) return 671 endif 672 673 if (index(line,'CURRENT FULLY').ne.0) then 674 if (getzmu(0)) then 675 call haszm(.true.) 676 endif 677 call search(line,'GRADIENT (HARTREE/BOHR)',istat) 678 if (istat.eq.0) return 679 else 680 call haszm(.false.) 681 endif 682 endif 683 684 call redel(line,3) 685 686 usnew = .false. 687 if (line(2:4).eq.'---') usnew = .true. 688 689 if (.not.usnew) then 690 call redel(line,2) 691 iatoms = 0 692 endif 693 694 do while (getlin(0).eq.1) 695 if (linlen(line).le.1) return 696 jatoms = jatoms + 1 697 if (.not.usnew) iatoms = iatoms + 1 698 ktype = nxtwrd(str,nstr,itype,rtype) 699 if (ktype.ne.2) goto 1000 700 ktype = nxtwrd(str,nstr,itype,rtype) 701 if (ktype.ne.1) goto 1000 702 ktype = nxtwrd(str,nstr,itype,rtype) 703 704 if (ktype.ne.3) goto 1000 705 if (.not.usnew) ianz(iatoms) = rtype 706 707 if (.not.usnew) then 708 do i=1,3 709 ktype = nxtwrd(str,nstr,itype,rtype) 710 if (ktype.ne.3) goto 1000 711 coo(i,iatoms) = rtype 712 end do 713 endif 714 715 do i=1,3 716 ktype = nxtwrd(str,nstr,itype,rtype) 717 if (ktype.ne.3) goto 1000 718 fxyz(i,jatoms) = rtype 719 end do 720 end do 721 722 return 723 7241000 istat = 0 725 return 726 727 end 728 729 subroutine geogus(formax,forrms,dismax,disrms,epoints,isav) 730 implicit double precision (a-h,o-z) 731 common /rdwr/ iun1,iun2,iun3,iun4,iun5 732 common /geocnv/ fmaxt,frmst,dmaxt,drmst,fgmin,fgmax,dgmin,dgmax, 733 & enmax,enmin,ngeoms,nepnts,igcvav,ifmxav,ifrmav, 734 & idmxav,idrmav,ieav,ifrav,mxpnt 735 character lstr*137 736 dimension formax(*),forrms(*),dismax(*),disrms(*),epoints(*) 737 dimension isav(*) 738 739c 740c Read Geometry Convergence data 741c 742 call rewfil 743 igcvav = 1 744 ifmxav = 1 745 ifrmav = 1 746 idmxav = 0 747 idrmav = 0 748 ieav = 1 749 nepnts = 0 750 ngeoms = 0 751 dmaxt = 0.0d0 752 fmaxt = 0.0d0 753 drmst = 0.0d0 754 frmst = 0.0d0 755 756 do i=1,mxpnt 757 call search(lstr,' NSERCH=',istat) 758 if (istat.eq.0) goto 100 759 if (index(lstr,'FAILURE TO LOCATE').ne.0) goto 100 760 ngeoms = ngeoms + 1 761 isav(i) = 1 762 i1 = index(lstr,'ENERGY=') 763 epoints(i) = reada(lstr,i1+7,len(lstr)) 764 call search(lstr,'MAXIMUM GRADIENT',istat) 765 if (istat.eq.0) goto 100 766 i1 = index(lstr,'MAXIMUM GRADIENT =') 767 formax(i) = reada(lstr,i1+18,len(lstr)) 768 i1 = index(lstr,'RMS GRADIENT =') 769 forrms(i) = reada(lstr,i1+14,len(lstr)) 770 771 end do 772 773100 continue 774 if (ngeoms.eq.0) then 775 igcvav = 0 776 ifmxav = 0 777 ifrmav = 0 778 idmxav = 0 779 idrmav = 0 780 ieav = 0 781 else 782 nepnts = ngeoms 783 endif 784 785 return 786 end 787 788 subroutine cnvgus 789 parameter (MAXITER=1000) 790 implicit double precision (a-h,o-z) 791 common /rdwr/ iun1,iun2,iun3,iun4,iun5 792 common /convrg/ convg1(MAXITER),convg2(MAXITER),cnvmax,cnvmin, 793 &jstrt1,jend1,jstrt2,jend2,icvav1,icvav2 794 common /curlin/ line 795 character*137 line,str 796 integer getlin 797 logical last,datlin 798 799c 800c Read Scf Convergence data 801c 802 call rewfil 803 icvav1 = 1 804 icvav2 = 1 805 806c SCF convergence first point 807 808 call searchd(line,' ITER EX',' ITER TOTAL ENERGY',istat) 809 if (istat.eq.0) goto 1000 810 811 jstrt1 = 0 812 813 do while (getlin(0).eq.1) 814 if (linlen(line).le.1) goto 100 815 if (datlin(line)) then 816 ktype = nxtwrd(str,nstr,itype,rtype) 817 if (ktype.ne.2) goto 1000 818 jend1 = itype 819 do i=1,3 820 ktype = nxtwrd(str,nstr,itype,rtype) 821 if (ktype.eq.3) then 822 convg1(jend1) = rtype 823 goto 50 824 endif 825 end do 82650 continue 827 if (jstrt1.eq.0) jstrt1 = jend1 828 endif 829 end do 830 831100 continue 832 833 834 last = .false. 835 836200 call searchd(line,' ITER EX',' ITER TOTAL ENERGY',istat) 837 if (istat.eq.0) goto 2000 838 839 last = .true. 840 841 jstrt2 = 0 842 843 do while (getlin(0).eq.1) 844 if (linlen(line).le.1) goto 200 845 if (datlin(line)) then 846 ktype = nxtwrd(str,nstr,itype,rtype) 847 if (ktype.ne.2) goto 2000 848 if (itype.gt.MAXITER) goto 2000 849 jend2 = itype 850 do i=1,3 851 ktype = nxtwrd(str,nstr,itype,rtype) 852 if (ktype.eq.3) then 853 convg2(jend2) = rtype 854 goto 500 855 endif 856 end do 857500 continue 858 if (jstrt2.eq.0) jstrt2 = jend2 859 endif 860 end do 861 862 return 863 8641000 icvav1 = 0 865 icvav2 = 0 866 return 867 8682000 if (.not.last) then 869 icvav2 = 0 870 endif 871 return 872 873 end 874 875 subroutine ugetfd(istat,coo) 876 implicit double precision (a-h,o-z) 877 parameter (maxfat=1000) 878 parameter (maxfrq=maxfat*3) 879 common /rdwr/ iun1,iun2,iun3,iun4,iun5 880 real freq,frmul,a 881 common /freq/ freq(maxfrq),a(3,maxfat),fcoo(3,maxfat), 882 & frint(maxfrq),ramint(maxfrq),nfreq,ihasi 883 common /athlp/ iatoms, mxnat 884 common /frwrk/ frthr,frmul,idirct,iframe,nframe,iloop,ifrq,normc 885 common /curlin/ line 886 character*137 line,str 887 integer getlin 888 dimension coo(3,*) 889 890 istat = 1 891 892 ivibs = 0 893 idirct = 1 894 nframe = 5 895 iframe = 0 896 call rewfil 897 898 call iatnox(natoms) 899 900 do i=1,natoms 901 do j=1,3 902 fcoo(j,i) = coo(j,i) 903 end do 904 end do 905 906c Read in Gamess US Frequencies 907 90810 itel = ivibs 909 call search(line,'FREQUENCY:',istat) 910 if (istat.eq.0) goto 100 911 call bckfil 912 if (getlin(0).eq.0) goto 100 913 ktype = nxtwrd(str,nstr,itype,rtype) 914 if (ktype.ne.1) goto 100 915 do i=1,9 916 ktype = nxtwrd(str,nstr,itype,rtype) 917 if (ktype.ne.3) then 918 if (ktype.eq.1.and.nstr.eq.1) then 919 if (str(1:1).eq.'I') then 920 ktype = nxtwrd(str,nstr,itype,rtype) 921 if (ktype.ne.3) goto 20 922 endif 923 endif 924 if (ktype.eq.0) goto 20 925 endif 926 ivibs = ivibs + 1 927 freq(ivibs) = rtype 928 end do 92920 continue 930 931c skip symmetry line if present 932 if (getlin(0).eq.0) goto 100 933 if (index(line,'SYMMETRY').ne.0) then 934c write(*,*) line(1:20) 935 else 936 call bckfil 937 endif 938 939c get intensities 940 941 if (getlin(0).eq.0) goto 100 942 if (index(line,'REDUCED').ne.0) then 943 if (getlin(0).eq.0) goto 100 944 endif 945 ktype = nxtwrd(str,nstr,itype,rtype) 946 if (ktype.ne.1) goto 100 947 if (nstr.eq.2.and.str.eq.'IR') 948 & ktype = nxtwrd(str,nstr,itype,rtype) 949 do i=1,9 950 ktype = nxtwrd(str,nstr,itype,rtype) 951 if (ktype.ne.3) then 952 if (ktype.eq.1.and.nstr.eq.1) then 953 if (str(1:1).eq.'I') then 954 ktype = nxtwrd(str,nstr,itype,rtype) 955 if (ktype.ne.3) goto 30 956 endif 957 endif 958 if (ktype.eq.0) goto 30 959 endif 960 ihasi = 1 961 itel = itel + 1 962 frint(itel) = rtype 963 ramint(itel) = 0.0d0 964 end do 96530 continue 966 goto 10 967 968100 if (ivibs.eq.0) istat = 0 969 970 nfreq = ivibs 971 call parptr(1,freq,freq,nfreq) 972 call parptr(112,frint,ramint,ihasi) 973 974 return 975 end 976 977 subroutine ucoorg(idebug,ifreq,istat) 978 implicit double precision (a-h,o-z) 979 parameter (maxfat=1000) 980 parameter (maxfrq=maxfat*3) 981 common /rdwr/ iun1,iun2,iun3,iun4,iun5 982 real freq,a 983 common /freq/ freq(maxfrq),a(3,maxfat),fcoo(3,maxfat), 984 & frint(maxfrq),ramint(maxfrq),nfreq,ihasi 985 common /curlin/ line 986 character*137 line,str 987 integer getlin 988 989c Get ifreq 'th Norm. Cordinates from Gamess US Output 990 991 istat = 1 992 call rewfil 993 call iatnox(iatoms) 994 99510 call search(line,'FREQUENCY:',istat) 996 if (istat.eq.0) goto 100 997 ivibs = 0 998 ihfor = 0 999 call bckfil 1000 call bckfil 1001 if (getlin(0).eq.0) goto 1000 1002 if (index(line,'FORCE CONST.:').ne.0) then 1003 ihfor = 1 1004 call bckfil 1005 call bckfil 1006 if (getlin(0).eq.0) goto 1000 1007 endif 1008 do i=1,9 1009 ktype = nxtwrd(str,nstr,itype,rtype) 1010 if (ktype.ne.2) goto 20 1011 ivibs = ivibs + 1 1012 if (itype.eq.ifreq) goto 100 1013 end do 101420 continue 1015 if (ihfor.eq.1) then 1016 call redel(line,3) 1017 else 1018 call redel(line,2) 1019 endif 1020 goto 10 1021 1022100 if (ihfor.eq.1) then 1023 call redel(line,3) 1024 else 1025 call redel(line,2) 1026 endif 1027c Skip next line in Gamess US 20 JUN 2002 Output 1028 if (index(line,'SYMMETRY:').ne.0) call redel(line,1) 1029 if (index(line,'REDUCED MASS:').ne.0) call redel(line,1) 1030 if (index(line,'INTENSITY:').ne.0) call redel(line,1) 1031 1032 do i=1,iatoms 1033 do j=1,3 1034 if (getlin(0).eq.0) goto 1000 1035 ktype = nxtwrd(str,nstr,itype,rtype) 1036 if (ktype.eq.2) then 1037 ktype = nxtwrd(str,nstr,itype,rtype) 1038 ktype = nxtwrd(str,nstr,itype,rtype) 1039 endif 1040 if (ktype.ne.1) goto 1000 1041 do k=1,ivibs 1042 ktype = nxtwrd(str,nstr,itype,rtype) 1043 end do 1044 if (ktype.ne.3) goto 1000 1045 a(j,i) = rtype 1046 end do 1047 end do 1048 1049 if (idebug.eq.1) call prtfr(ifreq) 1050 return 1051 10521000 istat = 0 1053 call inferr('Error reading Norm. Coords. !',0) 1054 return 1055 end 1056 1057 subroutine getzzz(istatz, 1058 & bl,alph,bet,ibl,ialph,ibet,imap,ianz,iz) 1059 1060c this is really getzmu 1061 1062 implicit double precision (a-h,o-z), integer ( i-n) 1063 integer getlin 1064 character*137 str 1065 character*2 catom,catomt,tolowf,iel 1066 common /zmfrst/ ihaszm, nz, mxzat 1067 common /rdwr/ iun1,iun2,iun3,iun4,iun5 1068 1069 dimension iel(100) 1070 character*137 line 1071 common /curlin/ line 1072 dimension bl(*),alph(*),bet(*),ibl(*),ialph(*),ibet(*), 1073 & imap(*),ianz(*),iz(4,*) 1074 data iel/'bq', 1075 & 'h ', 'he', 1076 & 'li', 'be', 'b ', 'c ', 'n ', 'o ', 'f ', 'ne', 1077 & 'na', 'mg', 'al', 'si', 'p ', 's ', 'cl', 'ar', 1078 & 'k ', 'ca', 1079 & 'sc', 'ti', 'v ', 'cr', 'mn', 1080 & 'fe', 'co', 'ni', 'cu', 'zn', 1081 & 'ga', 'ge', 'as', 'se', 'br', 'kr', 1082 & 'rb','sr','y ','zr','nb','mo','tc','ru','rh','pd','ag','cd', 1083 & 'in','sn','sb','te','i ','xe','cs','ba','la','ce','pr','nd', 1084 & 'pm','sm','eu','gd','tb','dy','ho','er','tm','yb','lu','hf', 1085 & 'ta','w ','re','os','ir','pt','au','hg','tl','pb','bi','po', 1086 & 'at','rn','fr','ra','ac','th','pa','u ','np','pu','am','cm', 1087 & 'bk','cf','x '/ 1088 1089 istatz = 0 1090 maxnz = mxzat 1091 do i=1,3 1092 do j=1,4 1093 iz(j,i) = 0 1094 end do 1095 end do 1096 nz = 0 1097 1098 do while (getlin(0).eq.1) 1099 ktype = nxtwrd(str,nstr,itype,rtype) 1100 if (ktype.eq.1) then 1101 if (nstr.le.8) then 1102 nz = nz + 1 1103 imap(nz) = 0 1104 numv = 3 1105 if (nz.le.3) numv = nz - 1 1106c 1107c Atom String 1108c 1109 if (nstr.eq.1) then 1110 catomt(1:1) = str(1:1) 1111 catomt(2:2) = ' ' 1112 else 1113 catomt = str(1:2) 1114 endif 1115 catom = tolowf(catomt) 1116 do j=1,100 1117 if (catom .eq. iel(j)) ianz(nz) = j - 1 1118 end do 1119 do j=1,numv 1120c 1121c Connectivity 1122c 1123 if (nxtwrd(str,nstr,itype,rtype).ne.2) then 1124 goto 100 1125 else 1126 iz(j,nz) = itype 1127 endif 1128c 1129c Variable 1130c 1131 ktype = nxtwrd(str,nstr,itype,rtype) 1132 if (ktype.eq.0.or.ktype.eq.1) then 1133 goto 100 1134 elseif (ktype.eq.2) then 1135 tmpvar = 1.0d0*itype 1136 elseif (ktype.eq.3) then 1137 tmpvar = rtype 1138 endif 1139 if (j.eq.1) then 1140 bl(nz) = tmpvar 1141 elseif (j.eq.2) then 1142 alph(nz) = tmpvar 1143 elseif (j.eq.3) then 1144 bet(nz) = tmpvar 1145 endif 1146 end do 1147c 1148c Check for Gamess ITYPE 1149c 1150 ktype = nxtwrd(str,nstr,itype,rtype) 1151 iz(4,nz) = 0 1152 if (ktype.ne.0) then 1153 if (ktype.eq.2.and.itype.eq.1.or.itype.eq.0) then 1154 iz(4,nz) = itype 1155 elseif (ktype.eq.3.and.rtype.eq.-1.0d0) then 1156 iz(4,nz) = -1 1157 else 1158 goto 100 1159 endif 1160 endif 1161 endif 1162c 1163c Empty Line 1164c 1165 elseif (ktype.eq.0.and.nz.gt.1) then 1166 goto 200 1167 endif 1168 end do 1169c 1170c Out of Lines, Didnt Find Zmat 1171c 1172100 continue 1173 1174 return 1175 1176200 continue 1177c 1178c Found Zmat 1179c 1180 1181 istatz = 1 1182 do i=1,nz 1183 ibl(i) = 1 1184 ialph(i) = 1 1185 ibet(i) = 1 1186 end do 1187c do i=1,nz 1188c print*,ianz(i),bl(i),alph(i),bet(i),(iz(j,i),j=1,4) 1189c end do 1190 1191 return 1192 end 1193 1194 subroutine gamunmr 1195 implicit double precision (a-h,o-z) 1196 parameter (numatm=2000) 1197 character*137 line,str 1198 common /curlin/ line 1199 integer getlin 1200 common /nmr/ shlnuc(numatm),ihsnmr 1201 common /moldat/ natoms, norbs, nelecs,nat(numatm) 1202 common /rdwr/ iun1,iun2,iun3,iun4,iun5 1203 1204 call search(line,'GIAO CHEMICAL SHIELDING TENSOR (PPM):',istat) 1205 1206 if (istat.ne.0) then 1207 call redel(line,1) 1208 do i=1,natoms 1209 call redel(line,6) 1210 if (getlin(0).ne.1) goto 1000 1211 ktype = nxtwrd(str,nstr,itype,rtype) 1212 if (ktype.eq.3) then 1213 shlnuc(i) = rtype 1214 else 1215 goto 1000 1216 endif 1217 end do 1218 ihsnmr = 2 1219 1220 endif 1221 1222 return 1223 12241000 call inferr('Error reading Isotropical Shielding !!',1) 1225 return 1226 end 1227 1228