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