      subroutine wrmod(iun,
     &               coo,qat,ianz,iaton,iatclr,iconn,iresid,
     &               lring,ityp,ipdbt,
     &               icalf,ncalf,iamino,ishoh)
      implicit double precision (a-h,p-z),integer (i-n),logical (o)
      parameter (mxcon=10)
      parameter (mxel=100)
      parameter (mxt=14)
      parameter (mxmol2=41)
      parameter (mxamb=1590)
      parameter (mxgff=72)
      parameter (mxres=42)
      parameter (mxsym=103)
      parameter (mxhsym=64)
      common /athlp/ iatoms, mxnat
      character*2 elemnt,tocapf,atom
      common /elem/elemnt(mxel)
      common /charge/ ihasq
      character*6 atmp
      character*4 atype
      common /atypes/ ihbt(mxt),atype(mxt)
      common /types/ iff
      character*5 mol2
      character*20 ambstr
      common /ftypes/ihasl(11),mol2(mxmol2),ambstr(mxamb)
      common /pdbon/ ipdbon
      character*3 pdbsym,hsym,ambtnk
      character*2 gffstr
      common /symbol/ pdbsym(mxsym),hsym(mxhsym),
     &                ambtnk(mxamb),gffstr(mxgff)
      character*3 aminos
      common /amino/aminos(mxres)
      real energy
      common /ener/iener,energy,lig(3),iprot(3),iconf
      logical ochg
      dimension ipdb(mxsym),ihpdb(mxhsym*3)
      dimension coo(3,*),qat(*),ianz(*),iaton(*),iatclr(*),
     &          iconn(mxcon+1,*),iresid(*),ityp(*),ipdbt(*),lring(*)
      dimension icalf(6,*),iamino(*)
      data atype /'    ','.1  ','.2  ','.3  ','.4  ','.ar ','.cat',
     &            '.am ','.pl3','.co2','.spc','.t3p','.O  ','.O2 '/
      data ihbt /   3   ,  1   ,  2   ,  3   ,  3   ,  4   ,  4   ,
     &              3   ,  3   ,  2   ,  3   ,  3   ,  2   ,  2   /

      toang = 0.52917706d0
      torad = datan(1.0d0) / 45.0d0

c     eerst geen h-bonds

      jflg = 0
      natoms = iatoms
      nbnds = 0
      idochg = 0

      if (ihasq.eq.1) idochg = 1

      iatred = 0
      do i=1,natoms
         if (.not.(ianz(i).eq.100.and.
     &        (iresid(i).le.0.and.iresid(i).ge.-3))) then
            iatred = iatred + 1
            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
         endif
      end do
      natoms = iatred

      do i=1,natoms
         lring(i) = 0
         iaton(i) = 2
      end do


      write(iun,'(a)') '@<TRIPOS>MOLECULE'

      if (iener.eq.1) then
         write(iun,'(a,f9.3,2(a,i3,x,i3,x,i3),a,i6)') 'E=',energy,
     &                           ' lig ',lig(1),lig(2),lig(3),
     &                           ' prot ',iprot(1),iprot(2),iprot(3),
     &                           ' conf ',iconf
      else
         write(iun,*) 'Molden generated mol2'
      endif

      write(iun,'(3(i6,1x))') natoms,nbnds,1
      write(iun,*) 'SMALL'

      if (idochg.eq.1) then
         write(iun,*) 'USER_CHARGES'
      else
         write(iun,*) 'NO_CHARGES'
      endif

      write(iun,*) '****'
      write(iun,*) '****'

      write(iun,'(a)') '@<TRIPOS>ATOM'

      do i=1,iatoms

               atom = tocapf(elemnt(ianz(i)))

               if (idochg.eq.1) then
                  q = qat(i)
               else
                  q = 0.0d0
               endif

               atmp = ' '//mol2(ityp(i))
               if (.not.(ianz(i).eq.100.and.
     &              (iresid(i).le.0.and.iresid(i).ge.-3))) then
                   write(iun,1000) 
     &                  i,atom,(coo(j,i)*toang,j=1,3),atmp,q
               endif
      end do

      write(iun,'(a)') '@<TRIPOS>BOND'

      ibnds = 1

      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)
                     if (ibt.eq.2) then
                        ifl1 = 0
                        ifl2 = 0
                        do jj=1,iconn(1,i)
                           kk = iconn(1+jj,i)
                           if (kk.gt.0.and.kk.ne.k) then
                               ibth = ibtyp(i,kk,idochg,0,ianz)
                               if (ibth.eq.2.or.ibth.eq.4) ifl1 = 1
                           endif
                        end do
                        do jj=1,iconn(1,k)
                           kk = iconn(1+jj,k)
                           if (kk.gt.0.and.kk.ne.i) then
                               ibth = ibtyp(k,kk,idochg,0,ianz)
                               if (ibth.eq.2.or.ibth.eq.4) ifl2 = 1
                           endif
                        end do
                        if (ifl1.eq.1.and.ifl2.eq.1) ibt = 1
                     endif
                     if (ibt.eq.4) then
                        write(iun,'(3(i6,1x),a)') ibnds,i,k,'    ar'
                     else
                        write(iun,'(4(i6,1x))') ibnds,i,k,ibt
                     endif
                     ibnds = ibnds + 1
                  endif
               endif
          end do
      end do

      write(iun,'(a)') '@<TRIPOS>SUBSTRUCTURE'
      write(iun,*) '     1 RES1       1'

      call chkmol2(iok)
      if (iok.eq.0) then
          print*,"WARNING Mol2: atom type inconsistancy,"
          print*,"Please retyp !"
      endif

      if (jflg.eq.1)
     &    print*,"WARNING Mol2: untyped atoms !"

      do i=1,natoms
         iaton(i) = 1
      end do

1000  format(i6,1x,a2,1x,3(f10.4,1x),a6,' 1 RES1',f10.4)
1001  format(i6,1x,a4,1x,3(f10.4,1x),a6,1x,i4,1x,a3,f10.4,1x,a)
1002  format(i6,1x,a4,1x,3(f10.4,1x),a6,1x,i4,1x,a4,f10.4,1x,a)

      return
      end

      subroutine ispnd(ispn,iat,irng,idochg,ifive,
     &                      qat,ianz,iaton,iconn,lwrit,lring)
      implicit double precision (a-h,p-z),integer (i-n),logical (o)
      parameter (mxcon=10)
      common /athlp/  iatoms, mxnat
      logical ringg
      real angle,dihed
      dimension iring(6),isel(4),icnn(mxcon),icnn2(mxcon),ioke(2)
      dimension qat(*),iconn(mxcon+1,*),ianz(*),iaton(*),
     &          lwrit(*),lring(*)

c ifive not only signals look for five membered aromatic rings
c but also c==0 counts for no Pi electrons
c
c determine number of bonds and filter out hydrogen bonds

      ibnds = 0
      inn = 0
      do i=1,iconn(1,iat)
         if (iconn(i+1,iat).gt.0) then
            ibnds = ibnds + 1
            icnn(ibnds) = iconn(i+1,iat)
            if (ianz(iconn(i+1,iat)).eq.7) inn = inn + 1
         endif
      end do

      ispn = 1
      irng = 0
      ian = ianz(iat)
      if (ian.eq.6) then
         ispn = 4
         if (ibnds.eq.3) then
            ispn = 3
            if (inn.eq.3) ispn = 7
         elseif (ibnds.eq.2) then
            ispn = 2
         endif
      elseif (ian.eq.7) then
         ispn = 4
         if (ibnds.eq.4) then
            ispn = 5
         elseif (ibnds.eq.1) then
            ispn = 2
         elseif (ibnds.eq.2) then
            isel(1) = icnn(1)
            isel(2) = iat
            isel(3) = icnn(2)
            ispn = 2
            call intcor(intc,angle,isel,3)
            if (intc.eq.1) then
                if (abs(angle).lt.170.0e0) ispn = 3
            endif
         elseif (ibnds.eq.3) then
            ispn = 4
            isel(1) = iat
            isel(2) = icnn(1)
            isel(3) = icnn(2)
            isel(4) = icnn(3)
            call intcor(intc,dihed,isel,4)
            if (intc.eq.1) then
                if (abs(dihed).lt.3.0e0) ispn = 9
            endif
            inco = 0
            do i=1,3
               jat = icnn(i)
               call flth(jat,icnn2,ibnds2,iconn)
               if (ianz(jat).eq.6.and.ibnds2.eq.3) then
                   do j=1,3
                      kat = icnn2(j)
                      if (ianz(kat).eq.8) then
                         call flth(kat,icnn2,ibnds2,iconn)
                         if (ibnds2.eq.1) inco = jat
                      endif
                   end do
               endif
            end do
            if (inco.ne.0) then
               iamid = 1
               do i=1,3
                  jat = icnn(i)
                  if (jat.ne.inco) then
                     if (.not.(ianz(jat).eq.1.or.ianz(jat).eq.6.or.
     &                         ianz(jat).eq.7))
     &                 iamid = 0
                  endif
               end do
               if (iamid.eq.1) ispn = 8
            endif
         endif
      elseif (ian.eq.8.or.ian.eq.16) then
         ispn = 4
         if (ibnds.eq.1) then
            ispn = 3
            jat = icnn(1)
            if (ian.eq.8.and.
     &         (ianz(jat).eq.15.or.ianz(jat).eq.6)) then
               ipo2 = 0
               call flth(jat,icnn2,ibnds2,iconn)
               do i=1,ibnds2
                  kat = icnn2(i)
                  if (kat.gt.0) then
                     if (ianz(kat).eq.8.and.
     &                icred(kat,idum1,idum2,ianz,iconn).eq.1) 
     &                      ipo2 = ipo2 + 1
                  endif
               end do
               if (ipo2.eq.2) ispn = 10
            endif
         endif
         if (ian.eq.16) then
            iso2 = 0
            do i=1,ibnds
               call flth(icnn(i),icnn2,ibnds2,iconn)
               if (ianz(icnn(i)).eq.8.and.ibnds2.eq.1)
     &            iso2 = iso2 + 1
            end do
            if (iso2.eq.1) ispn = 13
            if (iso2.eq.2) ispn = 14
         endif
      elseif (ian.eq.15) then
         ispn = 4
      endif

      if (ian.ne.6.and.ian.ne.7.and.ian.ne.8.and.ian.ne.15
     &    .and.ian.ne.16) return

      do i=1,iatoms
         lring(i) = 0
      end do

      do ii=1,2
         ioke(ii) = 0
         narel = 0
         if (ringg(iat,iring,nring,.true.,ianz,iaton,iconn,
     &             lwrit,lring)) then
            irng = -1
            if (nring.eq.6.or.nring.eq.5) then
               do i=1,nring
                  jat = iring(i)
                  iann = ianz(jat)
                  if (iann.eq.6) then
                     narel = narel + 1
                     if (ifive.eq.1) then
                        call flth(jat,icnn2,ibnds2,iconn)
                        do j=1,ibnds2
                           kat = icnn2(j)
                           if (ianz(kat).eq.8.or.
     &                         ianz(kat).eq.16) then
                              if (icred(kat,idum1,idum2,ianz,iconn)
     &                            .eq.1) narel = narel - 1
                           endif
                        end do
                     endif
                  elseif (iann.eq.8.or.iann.eq.16) then
                     narel = narel + 2
                  elseif (iann.eq.15) then
                     narel = narel + 1
                  elseif (iann.eq.7) then
                     call flth(jat,icnn2,inb,iconn)
                     if (inb.eq.2.or.inb.eq.3) then
                        if (inb.eq.3) then
                           if (idochg.eq.1) then
                              if (abs(qat(jat)-1.0d0).gt.0.1d0) then
                                 narel = narel + 2
                              else
                                 narel = narel + 1
                              endif
                           else
                              narel = narel + 2
                           endif
                        elseif (inb.eq.2) then
                           narel = narel + 1
                        endif
                     else
                        ioke(ii) = 0
                     endif
                  endif
               end do
            endif
            if ((nring.eq.6.or.(nring.eq.5.and.ifive.eq.1))
     &         .and.narel.eq.6) ioke(ii) = nring
            do i=1,nring
               lring(iring(i)) = 1
            end do
         endif
      end do
      if (ioke(1).gt.0.or.ioke(2).gt.0) then
          if (ian.ne.8) ispn = 6
          if (ioke(1).eq.6.or.ioke(2).eq.6) irng = 1
          if (ioke(1).eq.5.or.ioke(2).eq.5) then
              irng = 2
              if (ian.eq.16) ispn = 3
          endif
          if (ioke(1).eq.6.and.ioke(2).eq.6) then
              irng = 3
          elseif (ioke(1).eq.5.and.ioke(2).eq.5) then
              irng = 4
          elseif (ioke(1).gt.0.and.ioke(2).gt.0) then
              irng = 5
          endif
      endif

      call flush
      return
      end 

      subroutine chkmld(iok,ianz,ityp)
      parameter (mxmol2=41)
      implicit double precision (a-h,p-z),integer (i-n),logical (o)
      save mol2ck
      common /athlp/ iatoms, mxnat
      dimension mol2ck(mxmol2),ianz(*),ityp(*)
      data mol2ck / 0,0,0,0,
     &    6,6,6,6,6,
     &    7,7,7,7,7,7,7,
     &    8,8,8,8,8,
     &    16,16,16,16,15,
     &    1,1,1,
     &    9,17,35,53,14,0,0,
     &    11,19,20,3,13/

      iok = 1

      imiss = 0
      do i=1,iatoms
         it = ityp(i)
         if (it.le.0) then
            iat1 = 0
         else
            iat1 = mol2ck(ityp(i))
         endif
         iat2 = ianz(i)
         if (iat1.ne.0) then
            if (iat1.ne.iat2) imiss = imiss + 1
            if (iat1.ne.iat2) print*,"i ",i
         endif
      end do

      if (imiss.gt.0) iok = 0

      return
      end

      subroutine flth(iat,icnn,ibnds,iconn)
      implicit double precision (a-h,p-z),integer (i-n),logical (o)
      parameter (mxcon=10)
      dimension iconn(mxcon+1,*),icnn(mxcon)

      ibnds = 0
      do i=1,iconn(1,iat)
         if (iconn(i+1,iat).gt.0) then
            ibnds = ibnds + 1
            icnn(ibnds) = iconn(i+1,iat)
         endif
      end do

      return
      end

      logical function ochg(idum,ianz)
      implicit double precision (a-h,p-z),integer (i-n),logical (o)
      parameter (numatm=2000)
      common /moldat/ natoms, norbs, nelecs,nat(numatm)
      dimension ianz(*)

      ochg = .true.
      if (natoms.eq.0) ochg = .false.
      do i=1,natoms
         if (nat(i).ne.ianz(i)) ochg = .false.
      end do

      return
      end

