1 subroutine getzd(natoms,izo,ido,istatz,cc,ianc, 2 & bl,alph,bet,ibl,ialph,ibet,imap,ianz,iz, 3 & c,cz,alpha,beta,ian) 4 5c this is really getzm 6 7 implicit double precision (a-h,o-z), integer ( i-n) 8 integer getlin 9 character*137 str 10 character*2 catom,catomt,tolowf,iel 11 parameter (maxat=1000) 12 parameter (maxat3=maxat*3) 13 logical oparse,ottest,oerror,ovar 14 common /zmfrst/ ihaszm, nz, mxzat 15 common /hlpzm/ iloos 16 common /rdwr/ iun1,iun2,iun3,iun4,iun5 17 dimension ian(*),c(3,*),cz(3,*),alpha(*),beta(*) 18 dimension ianc(*),cc(3,*) 19 dimension bl(*),alph(*),bet(*),ibl(*),ialph(*),ibet(*), 20 & imap(*),ianz(*),iz(4,*) 21 22 dimension iel(100) 23 character*10 varnam,vartmp 24 character*1 stmp 25 dimension varnam(maxat3),ivar(maxat3),rvar(maxat3),ilnk(maxat3) 26 character*137 line 27 common /curlin/ line 28 data iel/'bq', 29 & 'h ', 'he', 30 & 'li', 'be', 'b ', 'c ', 'n ', 'o ', 'f ', 'ne', 31 & 'na', 'mg', 'al', 'si', 'p ', 's ', 'cl', 'ar', 32 & 'k ', 'ca', 33 & 'sc', 'ti', 'v ', 'cr', 'mn', 34 & 'fe', 'co', 'ni', 'cu', 'zn', 35 & 'ga', 'ge', 'as', 'se', 'br', 'kr', 36 & 'rb','sr','y ','zr','nb','mo','tc','ru','rh','pd','ag','cd', 37 & 'in','sn','sb','te','i ','xe','cs','ba','la','ce','pr','nd', 38 & 'pm','sm','eu','gd','tb','dy','ho','er','tm','yb','lu','hf', 39 & 'ta','w ','re','os','ir','pt','au','hg','tl','pb','bi','po', 40 & 'at','rn','fr','ra','ac','th','pa','u ','np','pu','am','cm', 41 & 'bk','cf','x '/ 42 43 istatz = 0 44 oparse = .false. 45 maxnz = mxzat 46 ottest=.true. 47 if (izo.eq.0) then 48 do i=1,3 49 do j=1,4 50 iz(j,i) = 0 51 end do 52 end do 53 nz = 0 54 endif 55 ikeyzm = 0 56 57 nzz = nz 58 59100 continue 60 ielins = 0 61 if (izo.eq.1) then 62 nz = nzz 63 else 64 nz = 0 65 endif 66 nzzt = 0 67 izmat = 0 68 do while (getlin(0).eq.1) 69 ktype = nxtwrd(str,nstr,itype,rtype) 70 if (ktype.eq.1) then 71 if ((str(1:4).eq.'vari'.or.str(1:4).eq.'VARI' 72 & .or.str(1:4).eq.'cons'.or.str(1:4).eq.'CONS' 73 & .or.str(1:4).eq.'end'.or.str(1:4).eq.'END').and.izmat.eq.1) 74 & then 75 ielins = 1 76 goto 200 77 endif 78 if (nstr.le.10.and. 79 & (str(1:4).eq.'zmat'.or.str(1:4).eq.'ZMAT')) then 80 nz = nzz 81 nzzt = 0 82 ikeyzm = 1 83 izmat = 1 84 goto 150 85 endif 86 if (nstr.le.10) then 87 nz = nz + 1 88 nzzt = nzzt + 1 89 numv = 3 90 if (nzzt.le.3) numv = nzzt - 1 91c 92c Atom String 93c 94 if (oparse) then 95 if (nstr.eq.1) then 96 catomt(1:1) = str(1:1) 97 catomt(2:2) = ' ' 98 else 99 catomt = str(1:2) 100 if (catomt(2:2).eq.'-') catomt(2:2) = ' ' 101 endif 102 catom = tolowf(catomt) 103 do j=1,100 104 if (catom .eq. iel(j)) ianz(nz) = j - 1 105 end do 106 if (catom.eq.'xx') ianz(nz) = 99 107 endif 108 do j=1,numv 109c 110c Connectivity 111c 112 if (nxtwrd(str,nstr,itype,rtype).ne.2) then 113 if (nzzt.eq.2) call bckfil 114 goto 100 115 else 116 if (oparse) iz(j,nz) = itype 117 endif 118c 119c Variable 120c 121 ktype = nxtwrd(str,nstr,itype,rtype) 122 if (ktype.eq.0) then 123 if (nzzt.eq.2) call bckfil 124 goto 100 125 elseif (ktype.eq.1.and.nstr.gt.10) then 126 if (nzzt.eq.2) call bckfil 127 goto 100 128 elseif (ktype.eq.1.and.oparse) then 129 ovar = .false. 130 do k=1,nvars 131 if (str(1:nstr).eq.varnam(k)(1:ivar(k))) then 132 tmpvar = rvar(k) 133 if (ilnk(k).le.0) then 134 ivart = ilnk(k)+1 135 ilnk(k) = nz 136 else 137 ivart = ilnk(k) 138 endif 139 ovar = .true. 140 endif 141 if (nstr.gt.1) then 142 if (str(2:nstr).eq.varnam(k)(1:ivar(k)).and. 143 & str(1:1).eq.'-') then 144 tmpvar = -rvar(k) 145 if (ilnk(k).le.0) then 146 ivart = ilnk(k)+1 147 ilnk(k) = nz 148 else 149 ivart = -ilnk(k) 150 endif 151 ovar = .true. 152 endif 153 if (str(2:nstr).eq.varnam(k)(1:ivar(k)).and. 154 & str(1:1).eq.'+') then 155 tmpvar = rvar(k) 156 if (ilnk(k).le.0) then 157 ivart = ilnk(k)+1 158 ilnk(k) = nz 159 else 160 ivart = ilnk(k) 161 endif 162 ovar = .true. 163 endif 164 endif 165 end do 166 if (.not.ovar.and.nvars.ne.0) then 167c if (nz.le.2) return 168 if (nzzt.le.2) then 169 if (nzzt.eq.2) call bckfil 170 goto 100 171 endif 172 call inferr( 173 & 'Gauss/Gamess: Missing Variable Name !',1) 174 call inferr( 175 & 'Variable: '//str(1:nstr),1) 176 return 177 endif 178 elseif (ktype.eq.2.and.oparse) then 179 tmpvar = 1.0d0*itype 180 ivart = 0 181 elseif (ktype.eq.3.and.oparse) then 182 tmpvar = rtype 183 ivart = 0 184 endif 185 if (oparse) then 186 if (j.eq.1) then 187 bl(nz) = tmpvar 188 if (izo.eq.1) then 189 ibl(nz) = 1 190 else 191 ibl(nz) = ivart 192 endif 193 elseif (j.eq.2) then 194 alph(nz) = tmpvar 195 if (izo.eq.1) then 196 ialph(nz) = 1 197 else 198 ialph(nz) = ivart 199 endif 200 elseif (j.eq.3) then 201 bet(nz) = tmpvar 202 if (izo.eq.1) then 203 ibet(nz) = 1 204 else 205 ibet(nz) = ivart 206 endif 207 endif 208 endif 209 end do 210c 211c Check for Gamess ITYPE 212c 213 ktype = nxtwrd(str,nstr,itype,rtype) 214 if (oparse) iz(4,nz) = 0 215 if (ktype.ne.0) then 216 if (ktype.eq.2) then 217 if (oparse.and.(abs(itype).eq.1.or.itype.eq.0)) 218 & iz(4,nz) = itype 219 elseif (ktype.eq.3) then 220 if (oparse.and.abs(rtype).eq.1.0d0) 221 & iz(4,nz) = int(rtype) 222 elseif (ktype.eq.1.and.nstr.eq.1) then 223 stmp = str(1:1) 224 if (stmp.eq.'L'.or.stmp.eq.'l'.or. 225 & stmp.eq.'H'.or.stmp.eq.'h'.or. 226 & stmp.eq.'M'.or.stmp.eq.'m') then 227 else 228 if (nzzt.eq.2) call bckfil 229 goto 100 230 endif 231 else 232 if (nzzt.eq.2) call bckfil 233 goto 100 234 endif 235 endif 236 endif 237c 238c Empty Line 239c 240 elseif (ktype.eq.0.and.nzzt.gt.1) then 241 ielins = 1 242 goto 200 243 else 244c 245c First word is not a string 246c 247 goto 100 248 endif 249150 continue 250 end do 251c 252c Out of Lines, Didnt Find Zmat 253c 254 255 return 256 257200 continue 258c 259c Found Zmat 260c 261 if (oparse) goto 500 262 263c 264c Get Variables Constants if any 265c 266300 if (ielins.eq.1) then 267 nvars = 0 268 do while (getlin(1).eq.1) 269 ktype = nxtwrd(str,nstr,itype,rtype) 270 if (ktype.eq.1) then 271 if (str(1:4).eq.'cons'.or.str(1:4).eq.'CONS') then 272 ielins = 2 273 elseif (str(1:3).eq.'end'.or.str(1:3).eq.'END') then 274 goto 400 275 else 276 if (nstr.gt.10) goto 400 277 vartmp = str 278 ntmp = nstr 279 ktype = nxtwrd(str,nstr,itype,rtype) 280 if (ktype.ne.2.and.ktype.ne.3) goto 400 281 nvars = nvars + 1 282 varnam(nvars) = vartmp 283 ivar(nvars) = ntmp 284 ilnk(nvars) = 0 285 if (ielins.eq.2) ilnk(nvars) = -1 286 if (ktype.eq.2) rvar(nvars) = 1.0d0*itype 287 if (ktype.eq.3) rvar(nvars) = rtype 288 endif 289 elseif (ktype.eq.0) then 290 ielins = ielins + 1 291 if (ielins.eq.3) goto 400 292 else 293 goto 400 294 endif 295 end do 296 endif 297 298400 if (ido.eq.1) then 299 icnt = 0 300 istmp = 0 301 do while (getlin(1).eq.1) 302 ktype = nxtwrd(str,nstr,itype,rtype) 303 if (ktype.eq.1) then 304 if (nstr.ge.3) then 305 if (icdex(str,'map').ne.0) istmp = 1 306 endif 307 elseif (ktype.eq.2.and.istmp.eq.1) then 308 do i=1,icnt 309 if (itype.eq.imap(i)) then 310 call inferr('Two map numbers are equal!!',0) 311 return 312 endif 313 end do 314 icnt = icnt + 1 315 imap(icnt) = itype 316 endif 317 end do 318 if (icnt.ne.nz) then 319 call inferr('Not enough map numbers !!',0) 320 return 321 endif 322 endif 323 324 if (ikeyzm.eq.1) then 325 call scback(line,'zmat',istat) 326 else 327 call rewfil 328 endif 329 330 oparse = .true. 331 goto 100 332 333500 continue 334 if (iloos.eq.0) then 335 if (nz.le.2) return 336 else 337 if (nz.lt.2) return 338 endif 339 istatz = 1 340c do i=1,nz 341c print*,ianz(i),bl(i),alph(i),bet(i),(iz(j,i),j=1,4) 342c end do 343 if (izo.eq.1.or.ido.eq.1) return 344 call stoc(maxnz,nz,0,0,0,ianz,iz,bl,alph,bet, 345 & ottest,natoms,ian,c,cz,imap,alpha,beta, 346 & oerror,.true.,.true.) 347 if (oerror) then 348 istatz = 0 349 else 350 ihaszm = 1 351 do i=1,natoms 352 do j=1,3 353 cc(j,i) = c(j,i) 354 end do 355 ianc(i) = ian(i) 356 end do 357 endif 358 359 return 360 end 361 362