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