      subroutine getpod(icom,ifd,iff,doscl,ioatms,ioadd,
     &                  coo,ianz,iaton,iconn)

      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (numat1=20000)
      parameter (mxcon=10)
      parameter (mxel=100)
      parameter (mxonh=100)
      parameter (numatm=2000)
      parameter (small=1.0d-4)
      common /thephi/theta1,phi1,rroot,rincr,vdwr(mxel),vrad(mxel),
     &               scal,fscal,scali,smag,ipoints,ipnt,icol(mxel)
      common /athlp/ iatoms, mxnat
      common /gamori/imap(numat1),cstand(3,numat1),istand(numat1),
     &               msucc
      common /gauori/ nzm,nso,nio,nzo,ioropt,ifor
      common /oniomh/ ioni,nion,ionih(mxonh),natonh(mxonh),
     &                iomap(numatm),icntat(mxonh),fct(mxonh),
     &                xyzi(3,mxonh)
      common /gxyz/   ixyz98, iopr, isymm, irc, imp2, icntp
      common /align/  vecs(3,3),nscnd,iscst,ialtyp,iocnt
      common /zmpart/ ipart,imn,imx,idcur
      common /coord / xyz(3,numatm)
      common /moldat/ natoms, norbs, nelecs,nat(numatm)
      common /rdwr/   iun1,iun2,iun3,iun4,iun5
      common /geocnv/ fdum3(10),idum(7),ieav,ifrav,mxpnt
      common /mopver/ mopopt

      character lstr*137
      character*3 astr
      character*8 refcod
      integer first,prev,next,last,xmol,getmf,doscl
      logical gamess,gauss,mopac,molpot,favail,oxyz,elpot,cpmd,chemx,
     & oisbin,doconv,dummy,dozme,gamus,ctoz
      logical adfin,gusirc,chpot,qchem,orca
      common /choic/mopac,gamess,gauss,molpot,elpot,chemx,cpmd,
     &              oisbin,gamus,ctoz,adfin,chpot,qchem,orca
      common /getpnt/ irtype,ipdbon,ipdbgro,xmol,favail,oxyz,
     &                doconv,dozme,gusirc
      common /slagau/ ihasd,isgau,ido5d,ido7f,ido9g,ihasg
      common /xyzopt/ ixyz,ichx,icrtp,ipdbwh,iambch
      common /cllab/ iclon,iclpnt(4)
      character*23 stmp
      dimension dum(3),coo(3,*),ianz(*),iaton(*),iconn(mxcon+1,*)

cd     write(iun3,'(a)')'enter subroutine getpoi'

      first = -1
      next  = -2
      last  = -3
      prev  = -4
      tol = small
      idoprt = 0

      icomm = icom

c for gaussian
 
      stmp = 'Input orientation:'
      ns = 18
      if (ixyz98.gt.0.and.(ioropt.eq.2)) then
          stmp = 'Standard orientation:'
          ns = 22
      endif

      if (dozme) then
c since dumzm resets the ipart variable, we need the help variable dopart
c this is because otherwise conpdb downstream goes wrong
          if (ipart.eq.1) idoprt = ipart
          favail = .false.
          call dumzm(coo,ianz,iatoms)
          goto 100
      endif

      if (oisbin.and..not.chemx) iatoms = 0


c     convert mopac coordinates to a.u.
c     vdwr are in angstrom, vrad in a.u.

      if (mopac.and.doconv) call xyzcoo(1,1,0)

      if (cpmd.and.ipoints.eq.0.and.(oxyz.or.irtype.eq.4)) then
          call xyzcoo(1,0,0)
          call haszm(.false.)
      endif

      if (gamess.and.ipoints.eq.0.and.(oxyz.or.irtype.eq.4).and.
     &    .not.gamus) then
          call xyzcoo(1,0,0)
          call haszm(.false.)
      endif
      if (gauss.and.(ipoints.le.1.or.irtype.eq.4).and.icomm.eq.-1) then
          rewind iun2
          call gaupoi(istat)
          if (istat.eq.-1) then
             favail = .false.
          else
             favail = .true.
          endif
          if ((istat.eq.0.or.irtype.eq.4).and.ioni.ne.1) 
     &          call xyzcoo(1,0,0)
          if (istat.eq.0) call haszm(.false.)
      endif
      
      if (icomm.eq.prev) then
          if ( ipnt.le.1 ) return
          ipnt = ipnt -1
          icomm = ipnt
      endif

      favail = .false.

      if (iatoms.eq.0.and..not.(gamess.or.gauss.or.cpmd)) then
          call inferr('No coordinates found !',0)
cd         write(iun3,'(a)')'leave subroutine getpoi'
          return
      endif

c Mopac2007 AUX file

      if (mopac.and.mopopt.eq.4.and.ipoints.ge.1) then

          if (icomm .eq. first) then
             rewind iun2
             call search(lstr,'HEAT_OF_FORM_UPDATED',istat)
             call readel(lstr,2)
             if (istat.eq.1) call gtapnt(iatoms,coo,istat) 
             if (istat.eq.1) ipnt = 1
          elseif (icomm .eq. next) then
             call search(lstr,'HEAT_OF_FORM_UPDATED',istat)
             call readel(lstr,2)
             if (istat.eq.1) call gtapnt(iatoms,coo,istat) 
             if (istat.eq.1) then
                ipnt = ipnt +1
             else
                rewind iun2
                call search(lstr,'HEAT_OF_FORM_UPDATED',istat)
                call readel(lstr,2)
                if (istat.eq.1) call gtapnt(iatoms,coo,istat) 
                if (istat.eq.1) ipnt = 1
             endif
          elseif (icomm.gt.0) then
             rewind iun2
             do i=1,icomm
                call search(lstr,'HEAT_OF_FORM_UPDATED',istat)
                call readel(lstr,2)
                if (istat.eq.1) call gtapnt(iatoms,coo,istat) 
                if (istat.eq.1) then
                    dummy = .true.
                else
                    dummy = .false.
                endif
             end do
             ipnt = icomm
          endif
          call xyzcoo(0,1,0)
      endif

      if (mopac.and..not.doconv.and.ipoints.ge.1) then
          if (icomm .eq. first) then
             rewind iun2
             call getmop(iatoms,heat,0,1,istat) 
             if (istat.eq.1) ipnt = 1
          elseif (icomm .eq. next) then
             call getmop(iatoms,heat,0,0,istat) 
             if (istat.eq.1) then
                ipnt = ipnt +1
             else
                rewind iun2
                call getmop(iatoms,heat,0,0,istat) 
                if (istat.eq.1) ipnt = 1
             endif
          elseif (icomm.gt.0) then
             rewind iun2
             idomopf = 1
             do i=1,icomm
                call getmop(iatoms,heat,0,idomopf,istat) 
                if (istat.eq.1) then
                    dummy = .true.
                else
                    dummy = .false.
                endif
                idomopf = 0
             end do
             ipnt = icomm
          endif
      endif

      if ((xmol.ge.1.or.(adfin.and.ihasg.ge.1)).and.ipoints.gt.1) then
          if (icomm .eq. first) then
             if (adfin) then
                call rewmf
                call srchmf(lstr,'[GEOMETRIES]',istat)
             else
                rewind iun2
             endif
             if (adfin.and.ihasg.eq.2) then
                call getzm(iatoms,0,0,istat)
                if (istat.eq.1) ipnt = 1
             else
                if (xmol.eq.2.or.xmol.eq.3) then
                   call gettnk(igttnk,0,ipdbon,iff,iheat,heat)
                   if (igttnk.eq.1) ipnt = 1
                elseif (xmol.eq.4) then
                   call getmol(igetmo)
                   if (igetmo.eq.1) ipnt = 1
                else
                   call getxyz(igetxy,heat,0)
                   if (igetxy.eq.1) ipnt = 1
                endif
             endif
             if (adfin) then
                iolin = getmf()
                call rdfc(ipnt,istat)
                if (istat.eq.1) then
                   favail = .true.
                else
                   favail = .false.
                endif
                call putmf(iolin)
             endif
          elseif (icomm .eq. next.and..not.(adfin.and.ifrav.eq.1)) then
             if (adfin.and.ihasg.eq.2) then
                call getzm(iatoms,0,0,istat)
                if (istat.eq.1) then
                   dummy = .true.
                else
                   dummy = .false.
                endif
             else
                if (xmol.eq.2.or.xmol.eq.3) then
                   call gettnk(igttnk,0,ipdbon,iff,iheat,heat)
                   if (igttnk.eq.1) then
                      dummy = .true.
                   else
                      dummy = .false.
                   endif
                elseif (xmol.eq.4) then
                   call getmol(igetmo)
                   if (igetmo.eq.1) then
                      dummy = .true.
                   else
                      dummy = .false.
                   endif
                else
                   call getxyz(igetxy,heat,0)
                   if (igetxy.eq.1) then
                       dummy = .true.
                   else
                       dummy = .false.
                   endif
                endif
             endif
             if (dummy) then
                ipnt = ipnt +1
             else
                if (adfin) then
                   call rewmf
                   call srchmf(lstr,'[GEOMETRIES]',istat)
                else
                   rewind iun2
                endif
                if (adfin.and.ihasg.eq.2) then
                   call getzm(iatoms,0,0,istat)
                   if (istat.eq.1) then
                      dummy = .true.
                   else
                      dummy = .false.
                   endif
                else
                   if (xmol.eq.2.or.xmol.eq.3) then
                      call gettnk(igttnk,0,ipdbon,iff,iheat,heat)
                      if (igttnk.eq.1) then
                         dummy = .true.
                      else
                         dummy = .false.
                      endif
                   elseif (xmol.eq.4) then
                      call getmol(igetmo)
                      if (igetmo.eq.1) then
                         dummy = .true.
                      else
                         dummy = .false.
                      endif
                   else
                      call getxyz(igetxy,heat,0)
                      if (igetxy.eq.1) then
                          dummy = .true.
                      else
                          dummy = .false.
                      endif
                   endif
                endif
                if (dummy) ipnt = 1
             endif
          elseif (icomm.gt.0.or.
     &           (icomm.eq.next.and.adfin.and.ifrav.eq.1)) then
             if (icomm.eq.next) then
                ipntt = ipnt + 1
                if (ipntt.gt.ipoints) ipntt = ipoints
             endif
             if (icomm.gt.0) ipntt = icomm
             if (adfin) then
                call rewmf
                call srchmf(lstr,'[GEOMETRIES]',istat)
             else
                rewind iun2
             endif
             do i=1,ipntt
                if (adfin.and.ihasg.eq.2) then
                   call getzm(iatoms,0,0,istat)
                   if (istat.eq.1) then
                      dummy = .true.
                   else
                      dummy = .false.
                   endif
                else
                   if (xmol.eq.2.or.xmol.eq.3) then
                      call gettnk(igttnk,0,ipdbon,iff,iheat,heat)
                      if (igttnk.eq.1) then
                         dummy = .true.
                      else
                         dummy = .false.
                      endif
                   elseif (xmol.eq.4) then
                      call getmol(igetmo)
                      if (igetmo.eq.1) then
                         dummy = .true.
                      else
                         dummy = .false.
                      endif
                   else
                      call getxyz(igetxy,heat,0)
                      if (igetxy.eq.1) then
                          dummy = .true.
                      else
                          dummy = .false.
                      endif
                   endif
                endif
             end do
             if (adfin) then
                call rdfc(ipntt,istat)
                if (istat.eq.1) then
                   favail = .true.
                else
                   favail = .false.
                endif
             endif
             ipnt = ipntt
          endif
      endif

      if (qchem) then
          if ( icomm .eq. first ) then
             call rewmf
             ipnt = 1
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
          elseif ( icomm .eq. last ) then
             call rewmf
             ipnt = ipoints
          elseif (icomm.gt.0) then
             call rewmf
             ipnt = icomm
          endif
          call qcxyz(0,.false.,ipnt,istat)
          if (istat.eq.-1) then
               favail = .false.
          else
               favail = .true.
          endif
      endif

      if (orca) then
          if ( icomm .eq. first ) then
             call rewmf
             ipnt = 1
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
          elseif ( icomm .eq. last ) then
             call rewmf
             ipnt = ipoints
          elseif (icomm.gt.0) then
             call rewmf
             ipnt = icomm
          endif
          call orcxyz(0,ipnt,istat)
          if (istat.eq.-1) then
               favail = .false.
          else
               favail = .true.
          endif
      endif

      if (gamess.and.ipoints.gt.0.and.(.not.gamus)) then
          if ( icomm .eq. first ) then
             rewind iun2
             ipnt = 1
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
          elseif ( icomm .eq. last ) then
             rewind iun2
             ipnt = ipoints
          elseif (icomm.gt.0) then
             rewind iun2
             ipnt = icomm
          endif
          if (oxyz) then
             itmp = ipnt - 1
             call gampoi(itmp,istat,oxyz)
          else
             call gampoi(ipnt,istat,oxyz)
          endif
          if ( istat .eq. -1 ) then
               favail = .false.
          else
               favail = .true.
          endif
c          if (msucc.eq.0.and..not.oxyz) favail = .false.
      endif

      if (gauss.and.ipoints.gt.1) then
          if ( icomm .eq. first ) then
             rewind iun2
             ipnt = 1
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
          elseif ( icomm .eq. last ) then
             rewind iun2
             do i=1,ipoints
                 if ((nzm.eq.nzo.or.2*nzm.eq.nzo).and.nzm.gt.0) then
                    call search(lstr,'Z-MATRIX (ANGSTROMS',istat)
                 elseif (nzo.gt.0) then
                    call search(lstr,'Z-Matrix orientation:',istat)
                 else
                    call search(lstr,stmp(1:ns),istat)
                 endif
             end do
             backspace iun2
             ipnt = ipoints
          elseif (icomm.gt.0) then
             rewind iun2
             do i=1,icomm
                 if ((nzm.eq.nzo.or.2*nzm.eq.nzo).and.nzm.gt.0) then
                    call search(lstr,'Z-MATRIX (ANGSTROMS',istat)
                 elseif (nzo.gt.0) then
                    call search(lstr,'Z-Matrix orientation:',istat)
                 else
                    call search(lstr,stmp(1:ns),istat)
                 endif
             end do
             backspace iun2
             ipnt = icomm
          endif
          call gaupoi(istat)
          if ( istat .eq. -1 ) then
               favail = .false.
          else
               favail = .true.
          endif
      endif

      if ( gamus.and..not.(ipoints.le.1.and.iatoms.gt.0) ) then
          if ( icomm .eq. first ) then
             rewind iun2
             ipnt = 1
             call gamupt(ipnt,istat)
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
             call gamupt(ipnt,istat)
          elseif ( icomm .eq. last ) then
             rewind iun2
             do i=1,ipoints
                call gamupt(ipoints,istat)
             end do
             backspace iun2
             ipnt = ipoints
          elseif (icomm.gt.0) then
             rewind iun2
             do i=1,icomm
                call gamupt(icomm,istat)
             end do
             backspace iun2
             ipnt = icomm
          endif
          favail = .true.
      endif

      if (cpmd.and..not.(ipoints.le.1.and.iatoms.gt.0)
     &     .and.irtype.ne.3 ) then
c          iunt = iun2
c          iun2 = iun5
          if ( icomm .eq. first ) then
             rewind iun2
             ipnt = 1
             call cpmdpt(ipnt,istat)
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
             call cpmdpt(ipnt,istat)
          elseif ( icomm .eq. last ) then
             rewind iun2
             do i=1,ipoints
                call cpmdpt(ipoints,istat)
             end do
             backspace iun2
             ipnt = ipoints
          elseif (icomm.gt.0) then
             rewind iun2
             do i=1,icomm
                call cpmdpt(icomm,istat)
             end do
             backspace iun2
             ipnt = icomm
          endif
          favail = .true.
c          iun2 = iunt
      endif

      if ( cpmd.and..not.(ipoints.le.1.and.iatoms.gt.0)
     &     .and.irtype.eq.3 ) then
          if (icomm.ne.first) then
             iunt = iun2
             iun2 = iun5
          endif
          if ( icomm .eq. first ) then
             rewind iun2
             ipnt = 1
             call cpmdpt(ipnt,istat)
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
             call cpmdptdyn(ipnt,istat)
          elseif ( icomm .eq. last ) then
             rewind iun2
             do i=1,ipoints
                call cpmdptdyn(ipoints,istat)
             end do
             backspace iun2
             ipnt = ipoints
          elseif (icomm.gt.0) then
             rewind iun2
             do i=1,icomm
                call cpmdptdyn(icomm,istat)
             end do
             backspace iun2
             ipnt = icomm
          endif
          favail = .true.
          if (icomm.ne.first) iun2 = iunt
      endif

      if (((icrtp.le.3.and.icrtp.ge.1).or.icrtp.eq.5)
     &     .and.ipoints.gt.1) then
          if (icomm.eq.first) then
             rewind iun2
             if (icrtp.eq.3) then
                call rfbio(0,1,istat)
             elseif (icrtp.eq.1) then
                call rdchx(0,3,0,0,0,istat,idum,1)
             elseif (icrtp.eq.5) then
                call getxdt(1,istat)
             else
                call rfdat(0,istat,refcod)
             endif
             ipnt = 1
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt +1
             if (icrtp.eq.3) then
                call rfbio(0,0,istat)
             elseif (icrtp.eq.1) then
                call rdchx(0,3,0,0,0,istat,idum,1)
             elseif (icrtp.eq.5) then
                call getxdt(ipnt,istat)
             else
                call rfdat(0,istat,refcod)
             endif
          elseif (icomm.gt.0) then
             rewind iun2
             if (icrtp.eq.3) then
                call rfbio(0,1,istat)
             elseif (icrtp.eq.1) then
                call rdchx(0,3,0,0,0,istat,idum,1)
             elseif (icrtp.eq.5) then
                call getxdt(icomm,istat)
             else
                call rfdat(0,istat,refcod)
             endif
             if (icrtp.ne.5) then
                do i=1,icomm-1
                   if (icrtp.eq.3) then
                      call rfbio(0,0,istat)
                   elseif (icrtp.eq.1) then
                      call rdchx(0,3,0,0,0,istat,
     &                           idum,1)
                   else
                      call rfdat(0,istat,refcod)
                   endif
                end do
             endif
             ipnt = icomm
          endif
          if (.not.(icrtp.eq.3.and.istat.eq.1)) 
     &       call fdat(ifd,0,0,0,0,0)
      endif

      if (ipdbon.eq.1.and.ipdbgro.eq.1) then
          if (icomm.eq.first) then
             ipnt = 1
             call gtfrm(ipnt)
          elseif ( icomm .eq. next ) then
             if ( ipnt.ge.ipoints ) return
             ipnt = ipnt + 1
             call gtfrm(ipnt)
          elseif (icomm.gt.0) then
             rewind iun2
             call gtfrm(icomm)
             ipnt = icomm
          endif
      endif

100   continue

      if (ioadd.eq.0) then
        if (.not.((gamess.and.ipoints.eq.0.and.(oxyz.or.irtype.eq.4))
     &    .or.(gauss.and.ipoints.le.1).or.
     &    (icrtp.eq.3.and.ipoints.gt.1).or.
     &    (ipdbon.eq.1.and.dozme))) call docent
      endif

      if (gamess.and.ipoints.gt.0.and..not.oxyz.and.msucc.eq.1
     &    .and.(.not.dozme).and.(.not.gamus).and.(.not.cpmd)) 
     &    call rotmom(ipnt,favail)


      ibeg = 1
      if (ioadd.eq.1) ibeg = ioatms + 1

      do i=ibeg,iatoms
         if (ipdbgro.eq.1) then
            if (ianz(i).eq.100.and.ipnt.gt.1) then
               if (i.gt.iclpnt(1)+7) iaton(i) = 0
            else
               iaton(i) = 1
            endif
         else
            iaton(i) = 1
         endif
      end do

      if (ipdbon.eq.1) then
         if (ialtyp.eq.1) then
            if (dozme) then
               call convar(coo,iconn,ianz,nscnd,iscst)
               call pmfass(1,0)
               call totpmf(dum(1))
               call upsco()
            endif
         else
            if (dozme) then
               if (idoprt.eq.0) call conpdb
               call chkbck
            endif
         endif
      else
         if ((.not.chemx.and.xmol.eq.0.and..not.(adfin.and.ihasg.eq.1))
     &        .or.(dozme.and..not.ichx.eq.1)) call doconn
      endif

      if (ipdbon.eq.0) then
         if (.not.ichx.eq.1) call dohcon(0)
      endif
c
c  get scale
c

      if (ioadd.eq.0) then
         if (doscl.eq.1.and..not.(icrtp.eq.3.and.ipoints.gt.1).and.
     &       .not.(ipdbon.eq.1.and.dozme)) then
            call doscal
            if (dozme.and.iatoms.lt.7) scali = 3.5d0
            scal = scali * 2.4d0 * smag
         endif
      endif

      if (favail) call parfc

      call drwgeo

      if (ctoz) call allzmt(ipdbon)
      if (.not.dozme) call upzme
      dozme = .false.


      if (icrtp.eq.2.and.ipoints.gt.1) then
          lstr = refcod
          call inferr(lstr,0)
cd         write(iun3,'(a)')'leave subroutine getpoi'
          return
      elseif (icrtp.eq.5.and.ipoints.gt.1) then
          call zerstr(ipnt,astr,3)
          lstr = 'point '//astr
          call inferr(lstr,0)
          return
      endif

      if (.not.(cpmd.or.gamess.or.gauss.or.(mopac.and..not.doconv)
     &    .or.(xmol.ge.1.and.ipoints.gt.1)).or.dozme) then
cd        write(iun3,'(a)')'leave subroutine getpoi'
         return
      endif

      if (ipoints.eq.0) then
         lstr = ' '
         if (.not.mopac) then
             lstr = 'Single point'
         endif
      elseif (ipnt.eq.1) then
         lstr = 'First point'
      elseif (ipnt.eq.ipoints) then
         lstr = 'Last point'
      else
         if (oxyz) then
            call zerstr(ipnt-1,astr,3)
         else
            call zerstr(ipnt,astr,3)
         endif
         lstr = 'point '//astr
      endif

      if (cpmd) lstr=lstr(1:22)//'CPMD output file'

      call inferr(lstr,0)

cd     write(iun3,'(a)')'leave subroutine getpoi'
      return
      end

      subroutine docond(coo,iconn,ianz)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (mxcon=10)
      common /athlp/ iatoms, mxnat
      dimension coo(3,*),ianz(*),iconn(mxcon+1,*)

      call convar(coo,iconn,ianz,iatoms,0)

      return
      end

      subroutine convar(coo,iconn,ianz,iatoms,ioff)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (mxel=100)
      parameter (mxcon=10)
      common /thephi/theta1,phi1,rroot,rincr,vdwr(mxel),vrad(mxel),
     &               scal,fscal,scali,smag,ipoints,ipnt,icol(mxel)
      common /rdwr/  iun1,iun2,iun3,iun4,iun5
      dimension coo(3,*),iconn(mxcon+1,*),ianz(*),ctemp(3)

      adjus=0.52917706d0

      do i=ioff+1,ioff+iatoms
         k = 0
         iconn(1,i) = 0
         do j=ioff+1,ioff+iatoms
            dmaxsq = (vdwr(ianz(i))+vdwr(ianz(j)))/adjus
            dmaxsq = dmaxsq*dmaxsq
            dijsq = 0
            do l=1,3
               ctemp(l) = coo(l,i) - coo(l,j)
               dijsq = dijsq + ctemp(l)*ctemp(l)
            end do
            if (i.ne.j.and.ianz(i).ne.99.and.ianz(j).ne.99) then
              if (dijsq.lt.dmaxsq) then
                  k = k + 1
                  if (k.le.mxcon) then
                     iconn(1,i) = k
                     iconn(k+1,i) = j
                  else
                     write(iun3,*) 
     &                  'more than mxconn connections found'
                  endif
              endif
            endif
         end do
      end do

      return
      end

      subroutine dohcod(ihflag,coo,ianz,iconn,isurf)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (mxcon=10)
      parameter (mxel=100)
      parameter (nacc=6)
      parameter (ndon=4)
      common /thephi/theta1,phi1,rroot,rincr,vdwr(mxel),vrad(mxel),
     &               scal,fscal,scali,smag,ipoints,ipnt,icol(mxel)
      common /athlp/ iatoms, mxnat
      logical hon
      common /hcon/ iacc(nacc),idon(ndon),hdmin,hdmax,hamin,hamax,hon
      common /rdwr/  iun1,iun2,iun3,iun4,iun5
      logical isacc,isdon
      real angle,hamin,hamax
      dimension ctemp(3),isel(4)
      dimension coo(3,*),ianz(*),iconn(mxcon+1,*),isurf(*)

      call domcon(1,1)

      if (.not.hon) return

      hdmin2 = hdmin*hdmin
      hdmax2 = hdmax*hdmax

c
c Hydrogen bonds
c
      do i=1,iatoms
         do j=i+1,iatoms
           if (ihflag.eq.0.or.
     &     (ihflag.gt.0.and.(isurf(i).eq.1.or.isurf(j).eq.1))) then
            iai = ianz(i)
            iaj = ianz(j)
            dijsq = 0
            do l=1,3
               ctemp(l) = coo(l,i) - coo(l,j)
               dijsq = dijsq + ctemp(l)*ctemp(l)
            end do
            if ((iai.eq.1.and.isacc(iaj)).or.
     &          (iaj.eq.1.and.isacc(iai))) then
               if (dijsq.gt.hdmin2.and.dijsq.lt.hdmax2) then
                  isel(1) = 0
                  if (iai.eq.1) then
                      if (iconn(1,i).gt.0) then
                         iai = ianz(iconn(2,i))
                         if (isdon(iai)) then
                            isel(1) = iconn(2,i)
                            isel(2) = i
                            isel(3) = j
                         endif
                      endif
                  else
                      if (iconn(1,j).gt.0) then
                         iaj = ianz(iconn(2,j))
                         if (isdon(iaj)) then
                            isel(1) = iconn(2,j)
                            isel(2) = j
                            isel(3) = i
                         endif
                      endif
                  endif
                  if (isel(1).ne.0) then
                    call intcor(intc,angle,isel,3)
                    if (intc.eq.1) then
                     if (abs(angle).gt.hamin.and.
     &                    abs(angle).lt.hamax) then
                         k = iconn(1,i)
                         if (k.lt.mxcon) then
                            iconn(1,i) = iconn(1,i) + 1
                            iconn(iconn(1,i)+1,i) = -j
                         else
                            write(iun3,*) 
     &                        'more than mxconn connections found'
                         endif
                         k = iconn(1,j)
                         if (k.lt.mxcon) then
                            iconn(1,j) = iconn(1,j) + 1
                            iconn(iconn(1,j)+1,j) = -i
                         else
                            write(iun3,*) 
     &                        'more than mxconn connections found'
                         endif
                     endif
                    endif
                  endif
               endif
            endif
           endif
         end do
      end do

      if (ihflag.eq.1) call clrsrf

      return
      end

      subroutine nohcod(iconn)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (mxcon=10)
      common /athlp/ iatoms, mxnat
      dimension icn(mxcon+1),iconn(mxcon+1,*)

c
c Deactivate Hydrogen bonds
c
      do i=1,iatoms
          inn = 0
          do j=1,iconn(1,i)
             if (iconn(1+j,i).gt.0) then
                inn = inn + 1
                icn(inn) = iconn(1+j,i)
             endif
          end do  
          iconn(1,i) = inn
          do j=1,inn
             iconn(1+j,i) = icn(j)
          end do
      end do

      return
      end

      logical function isacc(iatnr)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (nacc=6)
      parameter (ndon=4)
      logical hon
      common /hcon/ iacc(nacc),idon(ndon),hdmin,hdmax,hamin,hamax,hon
      real hamin,hamax

      isacc = .false.

      do i=1,nacc
          if (iatnr.eq.iacc(i)) isacc = .true.
      end do

      return
      end

      logical function isdon(iatnr)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (nacc=6)
      parameter (ndon=4)
      logical hon
      common /hcon/ iacc(nacc),idon(ndon),hdmin,hdmax,hamin,hamax,hon
      real hamin,hamax

      isdon = .false.

      do i=1,ndon
          if (iatnr.eq.idon(i)) isdon = .true.
      end do

      return
      end

      subroutine doscad(coo)
      implicit double precision (a-h,p-z),integer (i-n),logical (o)
      parameter (mxel=100)
      common /thephi/theta1,phi1,rroot,rincr,vdwr(mxel),vrad(mxel),
     &               scal,fscal,scali,smag,ipoints,ipnt,icol(mxel)
      common /athlp/ iatoms, mxnat
      common /rotmat/rx(3),ry(3),rz(3),t(3),td(3)
      common /pers/xv,yv,zv,c0,pincr,ssincr,xincr,yincr
      common /gracom/  uscl,colscd,colscpd,ivdwpl
      dimension coo(3,*)

      scali = 0.0d0
      do i=1,iatoms
         dist = 0.0d0
         do j=1,3
             dt = coo(j,i)-t(j)
             dist = dist + dt*dt
         end do
         if (dist.gt.scali) scali = dist
      end do
      scali = dsqrt(scali)
      scal = scali * 2.4d0 * smag

      if (scali.gt.15.0d0) then
         colscpd = 1.3d0
      else
         colscpd = .4d0
      endif

      colscd = 2.0d0

      zv = scali
      pincr = 0.02d0*scali

      return
      end

      subroutine redcod(iconn)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (mxcon=10)
      common /athlp/ iatoms, mxnat
      dimension icnn(mxcon),iconn(mxcon+1,*)

      do j=1,iatoms
         ibnds = 0
         do i=1,iconn(1,j)
            ioke = 1
            do k=1,i-1
               if (iconn(k+1,j).eq.iconn(i+1,j)) ioke = 0
            end do
            if (ioke.eq.1.and.ibnds.lt.mxcon) then
               ibnds = ibnds + 1
               icnn(ibnds) = iconn(i+1,j)
            endif
         end do
         iconn(1,j) = ibnds
         do i=1,ibnds
            iconn(i+1,j) = icnn(i)
         end do
      end do

      return
      end

      subroutine domcod(ipt,idoall,iconn)
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      parameter (mxcon=10)
      parameter (maxdm=20)
      parameter (numcal=5000)
      parameter (mxheta=50)
      common /distmn/ rdm(maxdm),idmon(2,maxdm),ndm
      integer srfmap, srfloc
      common /hlpsrf/ npts1,npts2,npts3,srfmap,srfloc,ifogl,itsrf,
     &                iams(numcal),ihets(mxheta)
      real rout
      dimension iconn(mxcon+1,*)


      if (idoall.eq.1) then
         ibeg = 1
         iend = ndm
      else
         ibeg = ipt
         iend = ipt
      endif

      do i=ibeg,iend
         call intcor(intc,rout,idmon(1,i),2)
         if (intc.eq.1) then
            rdm(i) = dble(rout)*0.52917706d0
            if (ifogl.ne.1) then
               i1 = idmon(1,i)
               i2 = idmon(2,i)
               k = iconn(1,i1)
               if (k.lt.mxcon) then
                  iconn(1,i1) = k + 1
                  iconn(k+2,i1) = -i2
               endif
               k = iconn(1,i2)
               if (k.lt.mxcon) then
                  iconn(1,i2) = k + 1
                  iconn(k+2,i2) = -i1
               endif
            endif
         endif
      end do

      if (ifogl.eq.1) call ogmon

      return
      end

      subroutine chkbck
      implicit double precision (a-h,p-x),integer (i-n),logical (o)
      integer fancy,shade,atcol,dolabs,persp
      logical fyesno,backb
      common /displ/ fancy,shade,atcol,dolabs,persp,irtcel,
     &               ifd,fyesno,backb,logo
      parameter (numcal=5000)
      parameter (mxchai=50)
      parameter (mxheta=50)
      parameter (mxres=42)
      integer reson
      common /calf/ icalf(6,numcal),ncalf,ianf(mxchai),islu(mxchai),
     &              nchain,iamino(numcal),iamicl(mxres),ihet(mxheta),
     &              iclhet(mxheta),reson(numcal),issdon

      if (backb) then
         call actcal(1)
         call ribbs
         if (ihet(1).eq.1) call acthel(1,0,0,0)
         if (ihet(2).eq.1) call acthel(1,1,0,0)
         if (ihet(3).eq.1) call acthel(1,2,0,0)
         if (ihet(4).eq.1) call acthel(1,3,0,0)
         do i=5,mxheta
            j = -i+1
            if (ihet(i).eq.1) then
               call actami(j,0,1,0)
            endif
         end do
         do i=1,ncalf
            if (reson(i).eq.1) then
               call actami(i,0,1,0)
            endif
         end do
      endif

      return
      end
