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