      subroutine getxyd(igetxy,heat,iaddprv,
     &                        coo,ianz,iaton,iatclr,iconn,qat)
      implicit double precision (a-h,o-z), integer ( i-n)
      integer getlin
      character*137 str
      character*2 catom, catomt, tolowf,iel
      parameter (numatm=2000)
      parameter (mxcon=10)
      parameter (maxsym=108)
      common /athlp/  iatoms, mxnat
      common /zmfrst/ ihaszm, nz, mxzat
      common /charge/ dipo(3),ihasq,ihsdp,iqon,idipon
      common /cllab/  iclon,iclpnt(4)
      common /surf/   natorg,noscnd
      common /cell/ nat,norg,icent,inorm,ico(3,8),icn(4,8),icol(32),ncon
      character*137 line
      common /curlin/ line
      logical favail,oxyz,doconv,dozme,gusirc
      integer xmol
      common /getpnt/ irtype,ipdbon,ipdbgro,xmol,favail,oxyz,
     &                doconv,dozme,gusirc
      logical mopac,gamess,gauss,molpot,elpot,chemx,oisbin,cpmd,
     &        gamus,ctoz,adfin,chpot,qchem,orca
      common /choic/  mopac,gamess,gauss,molpot,elpot,chemx,cpmd,
     &                oisbin,gamus,ctoz,adfin,chpot,qchem,orca
      common /xyzopt/ ixyz,ichx,icrtp,ipdbwh,iambch
      common /align/  vecs(3,3),nscnd,iscst,ialtyp,iocnt
      common /celpar/ xa,ya,yb,za,zb,zc,a,b,c,alpha,beta,gamma,nspg,kz
      common /rdwr/   iun1,iun2,iun3,iun4,iun5

      logical addcel,gnreal,dall
      dimension iel(maxsym),icel(8),rr(3,3)
      dimension coo(3,*),ianz(*),iaton(*),iatclr(*),iconn(mxcon+1,*),
     &          qat(*)
      data iel/'bq',
     &         'h ', 'he',
     &         'li', 'be', 'b ', 'c ', 'n ', 'o ', 'f ', 'ne',
     &         'na', 'mg', 'al', 'si', 'p ', 's ', 'cl', 'ar',
     &         'k ', 'ca',
     &                     'sc', 'ti', 'v ', 'cr', 'mn',
     &                     'fe', 'co', 'ni', 'cu', 'zn',
     &                     'ga', 'ge', 'as', 'se', 'br', 'kr',
     & 'rb','sr','y ','zr','nb','mo','tc','ru','rh','pd','ag','cd',
     & 'in','sn','sb','te','i ','xe','cs','ba','la','ce','pr','nd',
     & 'pm','sm','eu','gd','tb','dy','ho','er','tm','yb','lu','hf',
     & 'ta','w ','re','os','ir','pt','au','hg','tl','pb','bi','po',
     & 'at','rn','fr','ra','ac','th','pa','u ','np','pu','am','cm',
     & 'bk','cf','x ','oo','oa','ob','oc','ab','bc','ac','zz'/

      igetxy = 1
      addcel = .false.
      dall = .false.
      ncell = 0
      toang = 0.52917706d0
      todeg = 45.0d0 / datan(1.0d0)

c get number of atoms

      if (gusirc) then
         call searcht(line,'***** BEGIN IRC',
     &      'TIME                Q          P',
     &      'KINETIC       POTENTIAL       TOTAL',istat)
         if (istat.eq.0) goto 100
         igust = 0
         if (index(line,'KINETIC').ne.0.or.
     &       index(line,'TIME').ne.0) then
            igust = 1
            call readel(line,1)
         endif
      else
         if (getlin(0).eq.1) then
            ktype = nxtwrd(str,nstr,itype,rtype)
            if (ktype.eq.2) then
               if (iaddprv.eq.1) then
                   iscst = iatoms
                   nscnd = itype
                   natoms = nscnd
                   if (iatoms+nscnd.gt.mxnat) then
                       dall = .true.
                       goto 100
                   endif
               else
                   iscst = 0
                   iatoms = itype
                   natoms = iatoms
                   if (iatoms.gt.mxnat) then
                       dall = .true.
                       goto 100
                   endif
               endif
            else
               goto 100
            endif
         else
            goto 100
         endif
      endif

c get Heat of formation

      heat = 0.0d0
      heato = 0.0d0
      iefnd = 0
      if (getlin(1).eq.1) then
          do while(.true.)
             ktype = nxtwrd(str,nstr,itype,rtype)
             if (gusirc) then
                if (ktype.eq.1) then
                    if (nstr.eq.2) then
                       if (str.eq.'E=') iefnd = 1
                    endif
                endif
             endif
             if (ktype.eq.3) then
                heato = heat
                heat = rtype
             endif
             if (gusirc) then
                if (ktype.eq.0.or.(ktype.eq.3.and.iefnd.eq.1)) then
                   if (igust.eq.1) heat = heato
                   goto 110
                endif
             else
                if (ktype.eq.0.or.ktype.eq.3) goto 110
             endif
          end do
      else
         goto 100
      endif
      
110   continue

      if (gusirc) then
         if (igust.eq.1) then
            call search(line,'CARTESIAN COORDINATES',istat)
         endif
         call readel(line,1)
         iatoms = 0
         do while (getlin(0).eq.1)

            if (line(1:4).eq.' ---') goto 120
            ktype = nxtwrd(str,nstr,itype,rtype)
            if (ktype.eq.1) then
               if (nstr.ge.4) then
                  if (str(1:4).eq.'****') goto 120
                  if (str(1:4).eq.'MASS') goto 120
               endif
            endif
            iatoms = iatoms + 1

            if (igust.eq.0) ktype = nxtwrd(str,nstr,itype,rtype)
            if (ktype.eq.3) then
               ianz(iatoms) = int(rtype)
            else
               goto 100
            endif

            if (.not.gnreal(coo(1,iatoms),3,.false.)) goto 100
c            print*,(coo(i,iatoms),i=1,3)
         end do

120      continue
         backspace iun2
         call doconn
         ihaszm = 0
         return
      endif

      do iat=iscst+1,iscst+natoms
         if (getlin(0).eq.1) then
           ktype = nxtwrd(str,nstr,itype,rtype)
           if (ktype.eq.1) then
                 iatmp = 0
                 if (nstr.eq.1) then
                    catomt(1:1) = str(1:1)
                    catomt(2:2) = ' '
                 else
                    catomt = str(1:2)
                 endif
                 catom = tolowf(catomt)
                 do j=1,maxsym
                    if (catom .eq. iel(j)) iatmp = j - 1
                 end do
                 if (catom.eq.'xx') iatmp = 99
                 if (iatmp.le.0.or.iatmp.gt.maxsym-1) goto 100
                 if (iatmp.eq.106.and.ncell.eq.0) iatmp = 89
                 if (iatmp.gt.99) then
                    icel(iatmp-99) = iat
                    addcel = .true.
                    ncell = ncell + 1
                 else
                    if (addcel) then
                        call inferr('Cell points before atoms',1)
                        goto 100
                    endif
                 endif
                 ianz(iat) = iatmp
           else
              goto 100
           endif
           do i=1,4
              ktype = nxtwrd(str,nstr,itype,rtype)
              if (ktype.eq.3) then
                 if (i.eq.4) then
                    qat(iat) = rtype
                    ihasq = 1
                 else
                    coo(i,iat) = rtype / toang
                 endif
              else
                 if (i.ne.4) goto 100
              endif
           end do
        else
          goto 100
        endif
      end do

      iatoms = natoms + iscst

c look for cell data

      if (getlin(0).ne.1) goto 130
      if (getlin(0).ne.1) then
         backspace iun2
         goto 130
      endif

      if (icdex(line,'Unit cell').eq.0) then

         backspace iun2
         backspace iun2

      else

         do i=1,3
           if (getlin(0).eq.1) then
              if (.not.gnreal(rr(1,i),3,.false.)) goto 100
           endif
         end do
         nspg = 1
         a = vlen(rr(1,1))
         b = vlen(rr(1,2))
         c = vlen(rr(1,3))
         call impsc(rr(1,2),rr(1,3),csa)
         call impsc(rr(1,1),rr(1,3),csb)
         call impsc(rr(1,1),rr(1,2),csc)
         alpha = dacos(csa)*todeg
         beta = dacos(csb)*todeg
         gamma = dacos(csc)*todeg
         call prcell
         call setop
         call cprot(nspg,.false.)
         call prop
         call cpmol(coo,ianz,iatclr,iconn)

         chemx = .true.
         ichx = 1
         call fdat(1,0,0,0,0,0)

      endif

130   continue

      if (iaddprv.eq.1) then
         do i=iscst+1,iscst+nscnd
             do j=1,3
                iaton(i) = 1
             end do
         end do
      endif

      if (addcel) iatoms = iatoms - 8
      if (iaddprv.eq.1) then
         call convar(coo,iconn,ianz,nscnd,iscst)
      else
         call cooxyz(ianz,iatoms)
         call doconn
      endif
      if (addcel) then
         natorg = iatoms
         iclon = 1
         iclpnt(1) = icel(1)
         iclpnt(2) = icel(2)
         iclpnt(3) = icel(3)
         iclpnt(4) = icel(4)
         do i=1,8
            l = icel(i)
            iconn(1,l) = icn(1,i)
            do j=2,4
               iconn(j,l) = iatoms + icn(j,i)
            end do
            ianz(l) = 100
            iatclr(l) = 11
         end do
         iatoms = iatoms + 8
      endif

      if (iaddprv.eq.0) ihaszm = 0

      return
100   if (dall) then
         rewind iun2
         iatoms = iscst
         igetxy = -1
         return
      endif
      igetxy = 0
      return
      end

      subroutine aln2md(iopt,istat,
     &                  coo,ianz,iaton,iatclr,iresid)
      implicit double precision (a-h,o-z)
      logical fndsnd,ocen
      parameter (mxpsav=100)
      common /athlp/ iatoms, mxnat
      common /align/ vecs(3,3),nscnd,iscst,ialtyp,iocnt
      common /cllmat/rrx(3),rry(3),rrz(3),tr(3),tz(3),tzorg(3),itz
      common /rotmat/rx(3),ry(3),rz(3),t(3), td(3)
      common /cllsav/rdum(12,mxpsav),npsav
      common /rdwr/  iun1,iun2,iun3,iun4,iun5
      dimension vec1(3),vec2(3),vec3(3)
      dimension coo(3,*),ianz(*),iaton(*),iatclr(*),iresid(*)

      istat = 1
      fndsnd = .false.
      ocen = .true.

      ialtyp = iopt

      if (ialtyp.eq.0) then
         call getxyz(igetxy,heat,1)
         if (igetxy.eq.1) then
             fndsnd = .true.
         else
             fndsnd = .false.
         endif
         if (.not.fndsnd) then
             call rdsrf(iun2,istats,iesp,1,0)
             if (istats.eq.1) fndsnd = .true.
         endif
         if (.not.fndsnd) then
            print*,'This is not an xyz or molden surface file !'
            istat = 0
            return
         endif
      else if (ialtyp.eq.1) then
         ioatms = iatoms
         do i=1,iatoms
            if (iresid(i).le.0.and.iresid(i).ge.-3) then
               ioatms = i - 1
               goto 3000
            endif
         end do
3000     namols = namols + 1
         iatoms = ioatms
         iscst = ioatms
         
         call pdbstd(istat,.true.,1)
         if (istat.eq.-1) then
            call allcoo(50000)
            call pdbstd(istat,.true.,1)
         endif
         if (istat.eq.1) then
            fndsnd = .true.
            call xyzcoo(0,1,1)
c
c commented out calfa because it added hydrogens to structure1 in 
c the space of structure 2: it SHOULD NOT do that
c            call calfa(istat,1,1,ioatms+1,1,1)
c
            call dohcon(2)
            ocen = .false.
            nscnd = iatoms - ioatms
         else
            istat = 0
            print*,'This is not a valid PDB file !'
            return
         endif
      else if (ialtyp.eq.2) then
         namols = namols + 1
         fndsnd = .true.
         ialtyp = 1
         ocen = .false.
      endif

      if (fndsnd) then

         call cntvec(vec1,coo,ianz,iscst)
         call cntvec(vec2,coo(1,iscst+1),ianz(iscst+1),nscnd)

         do i=1,3
             vec3(i) = vec1(i) - vec2(i) 
         end do

         if (ialtyp.ne.1) then

            do i=1,nscnd
               call trcoo(vec3,coo(1,iscst+i))
            end do

            do i=1,3
               tr(i) = vec1(i)
            end do

         else

c set center of mol2  (tr)
c set pos mol2 to center of mol1 (tz)

            do i=1,3
               tr(i) = vec2(i)
               if (iocnt.eq.1) then
                  tz(i) = vec3(i)
               else
                  tz(i) = 0.0d0
               endif
            end do
c
c           copy coordinates of second molecule to the top of the
c           coordinate array
c
            nstrt = mxnat-nscnd
            do i=1,nscnd
               do j=1,3
                  coo(j,nstrt+i) = coo(j,iscst+i)
               end do
               ianz(nstrt+i) = ianz(iscst+i)
            end do
         endif

         if (ocen) call docent


         do i=1,iscst
             if (ianz(i).ne.100) then
                iatclr(i) = 1
             endif
         end do
         do i=iscst+1,iscst+nscnd
             iatclr(i) = 5
             iaton(i) = 1
             iresid(i) = -4
         end do

         if (ialtyp.eq.1) then
c vec1 is just a dummy in this case, doesnt do anything
c            call inirot
            call clini
            call alnrot(vec1,1)
            call ligzmt
            call pmfass(0,0)
            npsav = 0
         endif

         call mtinv3
         call rarbxi
         call rarbyi
         call rarbzi

      endif

      return
      end

      subroutine alnrod(vec,irot,coo)
      implicit double precision (a-h,o-z)
      common /athlp/ iatoms, mxnat
      common /cllmat/rx(3),ry(3),rz(3),t(3),tz(3),tzorg(3),itz
      common /align/ vecs(3,3),nscnd,iscst,ialtyp,iocnt
      dimension vec(3),tzt(3)
      dimension coo(3,*)

      nstrt = mxnat-nscnd

      if (irot.eq.1) then

c do rotation

         if (ialtyp.eq.1) then

            do i=1,nscnd
               x = coo(1,nstrt+i)
               y = coo(2,nstrt+i)
               z = coo(3,nstrt+i)
               coo(1,iscst+i) = 
     &           (x-t(1))*rx(1)+(y-t(2))*rx(2)+(z-t(3))*rx(3)+t(1)
               coo(2,iscst+i) = 
     &           (x-t(1))*ry(1)+(y-t(2))*ry(2)+(z-t(3))*ry(3)+t(2)
               coo(3,iscst+i) = 
     &           (x-t(1))*rz(1)+(y-t(2))*rz(2)+(z-t(3))*rz(3)+t(3)
               do j=1,3
                  coo(j,iscst+i) = coo(j,iscst+i) + tz(j)
               end do
            end do

         else

            do i=iscst+1,iscst+nscnd
               x = coo(1,i)
               y = coo(2,i)
               z = coo(3,i)
               coo(1,i) = 
     &            (x-t(1))*rx(1)+(y-t(2))*rx(2)+(z-t(3))*rx(3)+t(1)
               coo(2,i) = 
     &            (x-t(1))*ry(1)+(y-t(2))*ry(2)+(z-t(3))*ry(3)+t(2)
               coo(3,i) = 
     &            (x-t(1))*rz(1)+(y-t(2))*rz(2)+(z-t(3))*rz(3)+t(3)
            end do

         endif

      else

c do translation

         if (ialtyp.eq.1) then
            do j=1,3
               tz(j) = tz(j) - vec(j)
            end do
            do i=1,nscnd
               x = coo(1,nstrt+i)
               y = coo(2,nstrt+i)
               z = coo(3,nstrt+i)
               coo(1,iscst+i) = 
     &           (x-t(1))*rx(1)+(y-t(2))*rx(2)+(z-t(3))*rx(3)+t(1)
               coo(2,iscst+i) = 
     &           (x-t(1))*ry(1)+(y-t(2))*ry(2)+(z-t(3))*ry(3)+t(2)
               coo(3,iscst+i) = 
     &           (x-t(1))*rz(1)+(y-t(2))*rz(2)+(z-t(3))*rz(3)+t(3)
               do j=1,3
                  coo(j,iscst+i) = coo(j,iscst+i) + tz(j)
               end do
            end do
            do j=1,3
               tzt(j) = tzorg(j) - tz(j)
            end do
            vl = vlen(tzt)
            if (vl.gt.1.0) call updres
         else
            do i=iscst+1,iscst+nscnd
               do j=1,3
                  coo(j,i) = coo(j,i) - vec(j)
               end do
            end do
            do j=1,3
               t(j) = t(j) + vec(j)
            end do
         endif

      endif

      return
      end

      subroutine alnsorg(iatom,coo)
      implicit double precision (a-h,o-z)
      common /athlp/ iatoms, mxnat
      common /cllmat/rx(3),ry(3),rz(3),t(3),tz(3),tzorg(3),itz
      common /align/ vecs(3,3),nscnd,iscst,ialtyp,iocnt
      dimension coo(3,*)

      nstrt = mxnat-nscnd

      if (ialtyp.eq.1) then

         if (iatom.le.iscst) then
             call inferr('This is not an atom of docked molecule !',0)
             return
         endif
         im = iatom - iscst

         x = coo(1,nstrt+im)
         y = coo(2,nstrt+im)
         z = coo(3,nstrt+im)

         xn = 
     &      (x-t(1))*rx(1)+(y-t(2))*rx(2)+(z-t(3))*rx(3)-(x-t(1))
         yn = 
     &      (x-t(1))*ry(1)+(y-t(2))*ry(2)+(z-t(3))*ry(3)-(y-t(2))
         zn = 
     &      (x-t(1))*rz(1)+(y-t(2))*rz(2)+(z-t(3))*rz(3)-(z-t(3))

         t(1) = x
         t(2) = y
         t(3) = z

         tz(1) = tz(1) + xn
         tz(2) = tz(2) + yn
         tz(3) = tz(3) + zn

      else

         do i=1,3
            t(i) = coo(i,iatom)
         end do

      endif


      return
      end

      subroutine alnsav()
      implicit double precision (a-h,o-z)
      parameter (mxpsav=100)
      common /cllmat/rx(3),ry(3),rz(3),t(3),tz(3),tzorg(3),itz
      common /cllsav/rxs(3,mxpsav),rys(3,mxpsav),rzs(3,mxpsav),
     &               tzs(3,mxpsav),npsav

      if (npsav.lt.mxpsav) then
         npsav = npsav + 1

         do j=1,3
            rxs(j,npsav) = rx(j)
            rys(j,npsav) = ry(j)
            rzs(j,npsav) = rz(j)
            tzs(j,npsav) = tz(j)
         end do

      endif

      return
      end

      subroutine alnwrd(coo,ianz)
      implicit double precision (a-h,o-z)
      parameter (mxel=100)
      common /athlp/ iatoms, mxnat
      parameter (mxpsav=100)
      common /cllmat/rx(3),ry(3),rz(3),t(3),tz(3),tzorg(3),itz
      common /cllsav/rxs(3,mxpsav),rys(3,mxpsav),rzs(3,mxpsav),
     &               tzs(3,mxpsav),npsav
      common /align/ vecs(3,3),nscnd,iscst,ialtyp,iocnt
      character*2 ggstr,tocapf, elemnt
      common /elem/elemnt(mxel)
      logical opfil
      dimension xyzt(3)
      dimension coo(3,*),ianz(*)

      toang = 0.52917706d0
      iun = 46
      ires = 1
      nstrt = mxnat-nscnd

      do l=1,npsav
         if (opfil(iun,'pose.'//ggstr(l-1),7,1,0,0)) then
            write(iun,'(a)') 'HEADER'
            do i=1,nscnd
               x = coo(1,nstrt+i)
               y = coo(2,nstrt+i)
               z = coo(3,nstrt+i)
               xyzt(1) = (x-t(1))*rxs(1,l)+(y-t(2))*rxs(2,l)+
     &                   (z-t(3))*rxs(3,l)+t(1)
               xyzt(2) = (x-t(1))*rys(1,l)+(y-t(2))*rys(2,l)+
     &                   (z-t(3))*rys(3,l)+t(2)
               xyzt(3) = (x-t(1))*rzs(1,l)+(y-t(2))*rzs(2,l)+
     &                   (z-t(3))*rzs(3,l)+t(3)
               do j=1,3
                  xyzt(j) = xyzt(j) + tzs(j,l)
               end do
               ian = ianz(nstrt+i)
               write(iun,'(a6,i5,1x,a4,1x,i3,2x,i4,4x,3f8.3)')
     &            'HETATM',i,tocapf(elemnt(ian))//'  ',
     &             ires,ires,(xyzt(j)*toang,j=1,3)
            end do
            close(iun)
         endif
      end do

      return
      end

      subroutine alnsed(isel,coo)
      implicit double precision (a-h,o-z)
      common /align/ vecs(3,3),nscnd,iscst,ialtyp,iocnt
      logical fyesno,backb
      integer dolabs,fancy,persp,shade,atcol
      common /displ/ fancy,shade,atcol,dolabs,persp,irtcel,
     &               ifd,fyesno,backb,logo
      dimension isel(6),isel1(3),isel2(3),vec(3),coo(3,*)

      do i=1,3
         j = isel((i-1)*2+1)
         if (j.le.iscst) then
            isel1(i) = j
         else
            call inferr('Not atom of molecule 1',0)
            return
         endif
         j = isel((i-1)*2+2)
         if (j.gt.iscst) then
            isel2(i) = j - iscst
         else
            call inferr('Not atom of molecule 2',0)
            return
         endif
      end do

      do i=1,3
          vec(i) = coo(i,isel(1)) - coo(i,isel(2))
      end do

      do i=1,nscnd
         call trcoo(vec,coo(1,iscst+i))
      end do
   
      call alntwo(coo,isel1,coo(1,iscst+1),nscnd,isel2)

      call setorg(isel(2))

      irtcel = 0

      return
      end

      subroutine getchd(igetca,qat)
      implicit double precision (a-h,o-z), integer ( i-n)
      parameter (numatm=2000)
      integer getlin
      common /moldat/ natoms, norbs, nelecs,nat(numatm)
      character*137 str
      common /charge/ dipo(3),ihasq,ihsdp,iqon,idipon
      character*137 line
      common /curlin/ line
      logical gnreal
      dimension r(3),qat(*)

      igetca = 1
      if (getlin(0).eq.1) then
         ktype = nxtwrd(str,nstr,itype,rtype)
         if (ktype.eq.2) then
            iatoms = itype
            if (iatoms.ne.natoms) goto 100
         else
            goto 100
         endif
      else
         goto 100
      endif
      call readel(line,1)

      do i=1,iatoms
         if (getlin(0).eq.1) then
           ktype = nxtwrd(str,nstr,itype,rtype)
           if (ktype.ne.1) goto 100
           if (.not.gnreal(r,3,.false.)) goto 100
           ktype = nxtwrd(str,nstr,itype,rtype)
           if (ktype.eq.3) then
               qat(i) = rtype
           else
               goto 100
           endif
         endif
      end do

      ihasq = 1

      return
100   igetca = 0
      return
      end

      double precision function deter(r)
      implicit double precision (a-h,o-z)
      dimension r(3,3)
c  calculate the determinant of a 3x3 matrix

      deter = r(1,1)*r(2,2)*r(3,3) - r(1,3)*r(2,2)*r(3,1) +
     &        r(2,1)*r(3,2)*r(1,3) - r(2,3)*r(3,2)*r(1,1) +
     &        r(3,1)*r(1,2)*r(2,3) - r(3,3)*r(1,2)*r(2,1)
      return
      end

      subroutine invmat3(r,ri)
      implicit double precision (a-h,o-z)
      dimension r(3,3),ri(3,3)

c  invert matrix M

      det = deter(r)
      ri(1,1) = (r(2,2)*r(3,3)-r(2,3)*r(3,2)) / det
      ri(1,2) = (r(1,3)*r(3,2)-r(1,2)*r(3,3)) / det
      ri(1,3) = (r(1,2)*r(2,3)-r(1,3)*r(2,2)) / det
      ri(2,1) = (r(2,3)*r(3,1)-r(2,1)*r(3,3)) / det
      ri(2,2) = (r(1,1)*r(3,3)-r(1,3)*r(3,1)) / det
      ri(2,3) = (r(1,3)*r(2,1)-r(1,1)*r(2,3)) / det
      ri(3,1) = (r(2,1)*r(3,2)-r(2,2)*r(3,1)) / det
      ri(3,2) = (r(1,2)*r(3,1)-r(1,1)*r(3,2)) / det
      ri(3,3) = (r(1,1)*r(2,2)-r(1,2)*r(2,1)) / det

      return
      end

      subroutine getmod(igetmo,coo,qat,ianz,iconn)
      implicit double precision (a-h,o-z), integer ( i-n)
      parameter (numatm=2000)
      parameter (mxcon=10)
      parameter (maxsym=108)
      character*80 title
      character*2 catom, catomt, tolowf,iel
      character*5 vers
      common /athlp/ iatoms, mxnat
      common /charge/ dipo(3),ihasq,ihsdp,iqon,idipon
      character*137 line
      common /curlin/ line
      character*137 cas,nsc
      common /regis/  cas,nsc
      common /rdwr/   iun1,iun2,iun3,iun4,iun5

      logical ocorin
      dimension iel(maxsym),ichg(8),iqtmp(8)
      dimension coo(3,*),ianz(*),qat(*),iconn(mxcon+1,*)
      data iel/'lp',
     &         'h ', 'he',
     &         'li', 'be', 'b ', 'c ', 'n ', 'o ', 'f ', 'ne',
     &         'na', 'mg', 'al', 'si', 'p ', 's ', 'cl', 'ar',
     &         'k ', 'ca',
     &                     'sc', 'ti', 'v ', 'cr', 'mn',
     &                     'fe', 'co', 'ni', 'cu', 'zn',
     &                     'ga', 'ge', 'as', 'se', 'br', 'kr',
     & 'rb','sr','y ','zr','nb','mo','tc','ru','rh','pd','ag','cd',
     & 'in','sn','sb','te','i ','xe','cs','ba','la','ce','pr','nd',
     & 'pm','sm','eu','gd','tb','dy','ho','er','tm','yb','lu','hf',
     & 'ta','w ','re','os','ir','pt','au','hg','tl','pb','bi','po',
     & 'at','rn','fr','ra','ac','th','pa','u ','np','pu','am','cm',
     & 'bk','cf','x ','oo','oa','ob','oc','ab','bc','ac','zz'/

      igetmo = 1
      ocorin = .false.

      iatoms = 0
      nbnds = 0

      toang = 0.52917706d0

c get title line

      read (iun2,'(a)',end=100,err=100) title
      if (title(1:4).eq.'$$$$') then
         call readel(line,1)
         read (iun2,'(a)',end=100,err=100) title
      endif

      read (iun2,'(a)',end=100,err=100) line

      read (iun2,'(a)',end=100,err=100) line
      if (line(1:6).eq.'Corina') ocorin = .true.

      read (iun2,'(a)',end=100,err=100) line
      if (linlen(line).ge.39) then
         read (line,'(i3,i3,6x,i1,21x,a5)',end=100,err=100) 
     &   iatoms,nbnds,ister,vers
         if (vers.ne.'V2000'.and.vers.ne.'V3000') goto 100
      else
         if (ocorin) then
            if (linlen(line).ge.6) then
               read (line,'(i3,i3)',end=100,err=100) 
     &            iatoms,nbnds
            endif
         else
            goto 100
         endif
      endif

      do i=1,mxnat
         qat(i) = 0.0d0
      end do
      ichgrec = 0

      do i=1,iatoms
         read (iun2,'(3f10.4,1x,a2,6x,i3)',end=100,err=100) 
     &       (coo(j,i),j=1,3),catomt,itchg
         do j=1,3
            coo(j,i) = coo(j,i) / toang
         end do
         iatmp = 0
         catom = tolowf(catomt)
         do j=1,maxsym
            if (catom .eq. iel(j)) iatmp = j - 1
         end do
         if (catom.eq.'lp') iatmp = 99
         if (iatmp.le.0.or.iatmp.gt.maxsym-1) goto 100
         ianz(i) = iatmp
         qat(i) = dble(itchg)
         iconn(1,i) = 0
      end do

      do i=1,nbnds
         read (iun2,'(3i3)',end=100,err=100) 
     &      iat1,iat2,ibndtyp
         if (iconn(1,iat1).lt.mxcon) then
            iconn(1,iat1) = iconn(1,iat1) + 1
            iconn(1+iconn(1,iat1),iat1) = iat2
         endif
         if (iconn(1,iat2).lt.mxcon) then
            iconn(1,iat2) = iconn(1,iat2) + 1
            iconn(1+iconn(1,iat2),iat2) = iat1
         endif
      end do


      do while (.true.) 
         read (iun2,'(a)',end=200,err=100) line
         if (linlen(line).ge.1) then
            if (line(1:6).eq.'M  CHG') then
               ihasq = 1
               if (ichgrec.eq.0) then
                  do i=1,iatoms
                     qat(i) = 0.0d0
                  end do
                  ichgrec = 1
               endif
               nchg = 0
               read(line,'(6x,i3)') nchg
               read(line,'(9x,8(1x,i3,1x,i3))') 
     &               (ichg(i),iqtmp(i),i=1,nchg)
               do i=1,nchg
                 qat(ichg(i)) = dble(iqtmp(i))
               end do
            else
               if (index(line,'<NSC>').ne.0) then
                  read (iun2,'(a)',end=200,err=100) nsc
               endif
               if (index(line,'<CAS_RN>').ne.0) then
                  read (iun2,'(a)',end=200,err=100) cas
               endif
            endif
         endif
      end do

      call cooxyz(ianz,iatoms)
200   continue
      ihaszm = 0

      return
100   igetmo = 0
      return
      end

      subroutine outmod(iun,coo,ianz,iconn)
      implicit double precision (a-h,o-z), integer ( i-n)
      parameter (mxcon=10)
      parameter (maxsym=108)
      parameter (mxel=100)
      character*2 elemnt,tocapf
      character*3 atom,atomt
      common /athlp/  iatoms, mxnat
      common /elem/   elemnt(mxel)
      character*137 line
      common /curlin/ line
      common /rdwr/   iun1,iun2,iun3,iun4,iun5
      dimension coo(3,*),ianz(*),iconn(mxcon+1,*)

      toang = 0.52917706d0
      natoms = iatoms
      nbnds = 0
      idochg = 0

      do i=1,natoms
         do j=1,iconn(1,i)
            if (iconn(1+j,i).gt.0) then
               if (iconn(1+j,i).gt.i) nbnds = nbnds + 1
            endif
         end do
      end do

      write(iun,'(a)') ' '
      write(iun,'(a)') '  -MOLDEN-'
      write(iun,'(a)') 'Molden generated mol file'
      write(iun,'(i3,i3,a)') natoms,nbnds,
     &          '  0  0  0  0  0  0  0  0999 V2000'

      do i=1,natoms
         atomt = '   '
         atomt(1:2) = tocapf(elemnt(ianz(i)))
         call leftj(atomt,atom)
         write(iun,'(3f10.4,a1,a3,a)') (coo(j,i)*toang,j=1,3),' ',
     &      atom, ' 0  0  0  0  0  0  0  0  0  0  0  0'
      end do

      do i=1,natoms
         do j=1,iconn(1,i)
            k = iconn(1+j,i)
            if (k.gt.0) then
               if (k.gt.i) then
                  ibt = ibtyp(i,k,idochg,0,ianz)
                  write(iun,'(3i3,a)') i,k,ibt,
     &               '  0  0  0  0'
               endif
            endif
         end do
      end do

      write(iun,'(a)') 'M  END'

      return
      end
