1      subroutine gaupod(istat,coo,ianz)
2      implicit double precision (a-h,p-w),integer (i-n),logical (o)
3      parameter (numat1=20000)
4      parameter (maxfat=1000)
5      parameter (numatm=2000)
6      real fxyz,fc
7      common /forcom/fxyz(3,maxfat),fc(3,maxfat)
8      common /athlp/ iatoms, mxnat
9      common /gauori/ nzm,nso,nio,nzo,ioropt,ifor,
10     &                ixyz98,iopr,isymm,irc,imp2,icntp,itd
11      common /moldat/ natoms, norbs, nelecs,nat(numatm)
12      common /rdwr/  iun1,iun2,iun3,iun4,iun5
13      character lstr*137
14      common /curlin/ lstr
15      character*23 stmp
16      character*25 sirc
17      integer getlin
18      logical gnreal
19      dimension itemp(numat1),ctemp(3,numat1)
20      dimension coo(3,*),ianz(*),r(3)
21
22      toang = 0.52917706d0
23      ig98 = 0
24
25      stmp = 'Input orientation:'
26      ns = 18
27      if (ixyz98.gt.0.and.(ioropt.eq.2)) then
28          stmp = 'Standard orientation:'
29          ns = 22
30      endif
31
32      sirc = 'Item               Value'
33      nis = 24
34      if (irc.eq.2) then
35         sirc = '  Delta-x Convergence'
36         nis = 21
37      endif
38
39c     istat = 0     no Z-Matrix orientation found
40c     istat = -1    no Cartesian Forces found
41c     istat = ge 1  both Standard orientation and forces found
42
43c
44c     Gaussian forces are in the Z-matrix orientation (not in standard)
45c
465     if ((nzm.eq.nzo.or.2*nzm.eq.nzo).and.nzm.gt.0.and.ixyz98.ne.2)
47     &   then
48         call search(lstr,'Z-MATRIX (ANGSTROMS',istat)
49      elseif (nzo.gt.0.and.ixyz98.ne.2) then
50         call search(lstr,'Z-Matrix orientation:',istat)
51      else
52         call search(lstr,stmp(1:ns),istat)
53      endif
54
55      if (istat.eq.0 ) return
56      if (index(lstr,'Z-MATRIX (ANGSTROMS').eq.0) then
57         call haszm(.false.)
58         call bckfil
59      else
60         call redel(lstr,2)
61         call convzmat(coo,ianz,iatoms,1,0,1)
62      endif
63
64      call searchd(lstr,'Z-Matrix orientation:',stmp(1:ns),istat)
65      if (istat.eq.0) then
66         return
67      else
68         call redel(lstr,2)
69         call nxtlin(lstr,jstat)
70         if (jstat.eq.1.or.jstat.eq.2) goto 100
71         if (icdex(lstr,'Type').ne.0) ig98 = 1
72         call redel(lstr,1)
73      endif
74
75      nz = 0
76
77      do while ( .true. )
78         if (getlin(1).eq.1) then
79            if (lstr(2:4).eq.'---') goto 10
80            nz = nz + 1
81            ktype = nxtwrd(lstr,nstr,itype,rtype)
82            ktype = nxtwrd(lstr,nstr,itype,rtype)
83            if (ktype.ne.2) goto 100
84            itemp(nz) = itype
85            if (ig98.eq.1) then
86               ktype = nxtwrd(lstr,nstr,itype,rtype)
87               if (ktype.ne.2) goto 100
88            endif
89            if (gnreal(r,3,.false.)) then
90                do j=1,3
91                   ctemp(j,nz) = r(j)
92                end do
93            else
94                goto 100
95            endif
96         endif
97      end do
98
9910    continue
100
101c get rid off dummy atoms
102
103      iatoms = 0
104      do 400 i=1,nz
105         if(itemp(i))400,500,500
106500      iatoms = iatoms + 1
107         ianz(iatoms) = itemp(i)
108         do j=1,3
109            coo(j,iatoms) = ctemp(j,i)
110         end do
111400   continue
112
113      do i=1,iatoms
114c         print*,'coo ',i,(coo(j,i),j=1,3)
115         do j=1,3
116             coo(j,i) = coo(j,i)/toang
117         end do
118      end do
119
120c gaussian 98 doesnt do more than 50 atoms forces print
121
122c      if (ixyz98.gt.0.and.iatoms.gt.50.and.iopr.eq.0) goto 100
123
124      if (((nzm.eq.nzo.or.2*nzm.eq.nzo).and.nzm.gt.0)
125     &   .or.nzo.gt.0) then
126         call searcht(lstr,'Forces (Hartrees/Bohr)',
127     &   'Z-MATRIX (ANGSTROMS',
128     &   'Z-Matrix orientation:',istat)
129      else
130         call searchd(lstr,'Forces (Hartrees/Bohr)',
131     &   stmp(1:ns),istat)
132      endif
133
134      if (istat.eq.0) goto 200
135      if (icdex(lstr,'Forces (Hartrees/Bohr)').eq.0) then
136           istat = -1
137           call bckfil
138           return
139      endif
140      call redel(lstr,2)
141      do i=1,iatoms
142         call nxtlin(lstr,jstat)
143         if (jstat.eq.1.or.jstat.eq.2) goto 200
144         read(lstr,'(23x,3(f15.9))',err=200)(fxyz(j,i),j=1,3)
145c         print*,(fxyz(j,i),j=1,3)
146      end do
147
148      if (irc.ne.0) then
149
150         if (((nzm.eq.nzo.or.2*nzm.eq.nzo).and.nzm.gt.0)
151     &      .or.nzo.gt.0) then
152            call searcht(lstr,sirc(1:nis),
153     &      'Z-MATRIX (ANGSTROMS',
154     &      'Z-Matrix orientation:',istat)
155         else
156            call searchd(lstr,sirc(1:ns),stmp(1:ns),istat)
157         endif
158         if (istat.eq.0) goto 300
159
160         if (irc.eq.1) then
161
162            if (icdex(lstr,'Item').eq.0) then
163                 call bckfil
164                 goto 300
165            endif
166
167            icv1 = 0
168            icv2 = 0
169            icv3 = 0
170            icv4 = 0
171
172            call redel(lstr,1)
173            if (icdex(lstr,'YES').ne.0) icv1 = 1
174            call redel(lstr,1)
175            if (icdex(lstr,'YES').ne.0) icv2 = 1
176            call redel(lstr,1)
177            if (icdex(lstr,'YES').ne.0) icv3 = 1
178            call redel(lstr,1)
179            if (icdex(lstr,'YES').ne.0) icv4 = 1
180            icv = icv1 + icv2 + icv3 + icv4
181            if (icv.ne.4) goto 5
182            istat = 1
183
184         elseif (irc.eq.2) then
185
186            if (icdex(lstr,' NOT met').ne.0) goto 5
187            istat = 1
188
189         endif
190
191      endif
192
193      return
194
195100   istat = 0
196      return
197200   istat =-1
198      return
199300   istat = 1
200      return
201      end
202