      subroutine wrmod(iun,
     &               coo,qat,ianz,iaton,iatclr,iconn,iresid,
     &               lring,iamap,ityp,ipdbt,
     &               icalf,ncalf,iamino,ishoh,
     &               nat,nspg,icel,
     &               a,b,c,alpha,beta,gamma)
      implicit double precision (a-h,p-z),integer (i-n),logical (o)
      parameter (mxcon=10)
      parameter (mxel=100)
      parameter (mxt=14)
      parameter (mxppmf=16)
      parameter (mxlpmf=26)
      parameter (mxmol2=41)
      parameter (mxmm3=164)
      parameter (mxchtp=136)
      parameter (mxmsf=235)
      parameter (mxamb=1590)
      parameter (mxgff=72)
      parameter (mxamo=201)
      parameter (mxres=42)
      parameter (mxsym=103)
      parameter (mxhsym=64)
      common /athlp/ iatoms, mxnat
      character*2 elemnt,tocapf,atom
      common /elem/elemnt(mxel)
      common /charge/ dipo(3),ihasq,ihsdp,iqon,idipon
      character*6 atmp
      character*4 atype,stmp
      common /atypes/ ihbt(mxt),atype(mxt)
      integer*2 ityp,ipdbt
      common /types/ iff
      character*2 ppmf, lpmf
      character*5 mol2
      character*19 mm3
      character*20 chmtnk
      character*20 ambstr,dtmp
      character*20 amostr
      character*4 chmsf
      common /ftypes/ihasl(11),mol2(mxmol2),mm3(mxmm3),chmtnk(mxchtp),
     &               chmsf(mxmsf),ambstr(mxamb),amostr(mxamo),
     &               ppmf(mxppmf),lpmf(mxlpmf)
      logical dozme
      common /getpnt/ irtype,ipdbon,ipdbgro,ifav,ioxyz,
     &                iconv,ircus,dozme
      character*3 chtnk,pdbsym,hsym,ambtnk
      character*2 amotnk,gffstr
      common /symbol/ pdbsym(mxsym),hsym(mxhsym),chtnk(mxchtp),
     &                ambtnk(mxamb),amotnk(mxamo),gffstr(mxgff)
      character*3 aminos
      common /amino/aminos(mxres)
      real energy
      character*31 stri
      common /ener/iener,energy,lig(3),iprot(3),iconf
      logical ochg
      dimension tr1(3),rr(3,3)
      dimension iamap(*)
      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 (icel.eq.1) then

         if (ochg(idum,ianz)) then
            idochg = 1
         else
            idochg = 0
         endif

         natoms = nat
         nstor = mxnat-natoms

         do i=1,natoms

            do j=1,3
               coo(j,i) = coo(j,nstor+i)
            end do

            ianz(i) = ianz(nstor+i)

            do j=1,iconn(1,nstor+i)+1
               iconn(j,i) = iconn(j,nstor+i)
            end do

            iatclr(i) = iatclr(nstor+i)

         end do

      else
         if (ihasq.eq.1) idochg = 1
      endif

      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
      if (ipdbon.eq.1) then
         irs = ncalf
         ireso = 0
         do i=1,natoms
            ires = iresid(i)
            if (ires.lt.-3.and.ires.ne.-ishoh) then
               if (ires.ne.ireso) then
                  ireso = ires
                  irs = irs + 1
               endif
            endif
         end do
         write(iun,'(3(i6,1x))') natoms,nbnds,irs
         write(iun,*) 'PROTEIN'
      else
         write(iun,'(3(i6,1x))') natoms,nbnds,1
         write(iun,*) 'SMALL'
      endif
      if (idochg.eq.1) then
         write(iun,*) 'USER_CHARGES'
      else
         write(iun,*) 'NO_CHARGES'
      endif
      write(iun,*) '****'
      write(iun,*) '****'

      if (ipdbon.eq.1) then
         write(iun,'(a)') '@<TRIPOS>DICT'
         write(iun,*) 'PROTEIN PROTEIN'
      endif

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

      if (icel.eq.1) then

         call setrr(alpha,beta,gamma,a,b,c,rr)
   
         do i=1,nat
            do k=1,3
               tr1(k) = trc(coo(1,i),rr,k)
            end do
            atom = tocapf(elemnt(ianz(i)))
            if (idochg.eq.1) then
               q = qat(i)
            else
               q = 0.0d0
            endif
            call ispn(irs,i,irng,idochg,0)
            atmp = atom//atype(irs)
            if (iff.eq.5) then
               if (ityp(i).le.0.or.ityp(i).gt.mxmol2) then
                  jflg = 1
                  atmp = ' '//mol2(1)
               else
                  atmp = ' '//mol2(ityp(i))
               endif
            endif
            write(iun,1000) i,atom,(tr1(j),j=1,3),atmp,q
         end do

      else

         if (ipdbon.eq.1) then

            do i=1,mxnat
               iamap(i) = 0
            end do 

            iat = 0
            irs = 0
            do i=1,ncalf
               irs = irs + 1

               call getpdb(i,ipdb,ihpdb)

c all non hydrogen residue atoms

               do j=1,mxsym

                ip = ipdb(j)

                if (ip.ne.0) then
                   iat = iat + 1
                   iamap(ip) = iat
                   if (idochg.eq.1) then
                      q = qat(ip)
                   else
                      q = 0.0d0
                   endif

                   atom = tocapf(elemnt(ianz(ip)))
                   call ispn(irss,ip,irng,idochg,0)
                   atmp = atom//atype(irss)

                   if (iff.eq.5) then
                      if (ityp(ip).le.0.or.ityp(ip).gt.mxmol2) then
                         jflg = 1
                         atmp = ' '//mol2(1)
                      else
                         atmp = ' '//mol2(ityp(ip))
                      endif
                   endif

                   iam = iamino(i)
                   if (iam.gt.0.and.iam.le.mxres) then
                      stmp = pdbsym(j)//' '
                   endif

                   if (j.ge.1.and.j.le.4) then
                       dtmp = 'BACKBONE|DICT|DIRECT'
                   else
                       dtmp = 'DICT'
                   endif

                   write(iun,1001) 
     &               iat,stmp,(coo(k,ip)*toang,k=1,3),atmp,i,
     &               aminos(iamino(i)),q,dtmp

                endif

               end do

c all hydrogen residue atoms

               do j=1,mxhsym*3

                  ihp = ihpdb(j)

                  if (ihp.ne.0) then
                     iat = iat + 1
                     iamap(ihp) = iat
                     if (idochg.eq.1) then
                        q = qat(ihp)
                     else
                        q = 0.0d0
                     endif
                     atom = tocapf(elemnt(ianz(ihp)))
                     call ispn(irss,ihp,irng,idochg,0)
                     atmp = atom//atype(irss)
                     if (iff.eq.5) then
                        if (ityp(ihp).le.0.or.ityp(ihp).gt.mxmol2) then
                           jflg = 1
                           atmp = ' '//mol2(1)
                        else
                           atmp = ' '//mol2(ityp(ihp))
                        endif
                     endif

                     ih = (j-1)/3 
                     il = j - ih*3
                     if (ihpdb(ih*3+2).eq.0) then
                        stmp = hsym(ih+1)//' '
                     else
                        if (hsym(ih+1)(3:3).ne.' ') then
                           stmp = hsym(ih+1)//char(48+il)
                        else
                           stmp = hsym(ih+1)//' '
                        endif
                     endif

                     dtmp = 'DICT'

                     write(iun,1001) 
     &               iat,stmp,(coo(k,ihp)*toang,k=1,3),atmp,i,
     &               aminos(iamino(i)),q,dtmp

                  endif

               end do

            end do

            igrp = 0
            ireso = 0
            do i=1,iatoms
               ires = iresid(i)
               if (ires.lt.-3.and.ianz(i).ne.100) then
                  iat = iat + 1
                  iamap(i) = iat
                  atom = tocapf(elemnt(ianz(i)))
                  if (idochg.eq.1) then
                     q = qat(i)
                  else
                     q = 0.0d0
                  endif
                  call ispn(irss,i,irng,idochg,0)
                  atmp = atom//atype(irss)
                  if (iff.eq.5) then
                     if (ityp(i).le.0.or.ityp(i).gt.mxmol2) then
                        jflg = 1
                        atmp = ' '//mol2(1)
                     else
                        atmp = ' '//mol2(ityp(i))
                     endif
                  endif
                  dtmp = '    '
                  if (ires.eq.-ishoh) dtmp = 'WATER'
                  if (ires.ne.ireso) then
                     ireso = ires
                     irs = irs + 1
                     igrp = igrp + 1
                     stmp = 'GRP'//char(48+igrp)
                  endif
                  write(iun,1002) 
     &              iat,atom,(coo(k,i)*toang,k=1,3),atmp,irs,
     &               stmp,q,dtmp
               endif
            end do

         else
            do i=1,iatoms
               atom = tocapf(elemnt(ianz(i)))
               if (idochg.eq.1) then
                  q = qat(i)
               else
                  q = 0.0d0
               endif
               call ispn(irs,i,irng,idochg,0)
               atmp = atom//atype(irs)
               if (iff.eq.5) then
                  if (ityp(i).le.0.or.ityp(i).gt.mxmol2) then
                     jflg = 1
                     atmp = ' '//mol2(1)
                  else
                     atmp = ' '//mol2(ityp(i))
                  endif
               endif
               if (.not.(ianz(i).eq.100.and.
     &              (iresid(i).le.0.and.iresid(i).ge.-3))) then
                  if (ipdbon.eq.1) then
                     ires = iresid(i)
                     if (ires.gt.0) then
                        iam = iamino(ires)
                        if (iam.gt.0.and.iam.le.mxres) then
                           if (ianz(i).eq.1) then
                              ih = (ipdbt(i)-1)/3
                              stmp = ' '//hsym(ih+1)
                           else
                              stmp = ' '//pdbsym(ipdbt(i))
                           endif
                        endif
                        if (ianz(i).ne.1.and.
     &                  (ipdbt(i).ge.1.and.ipdbt(i).le.4)) then
                            dtmp = 'BACKBONE|DICT|DIRECT'
                        else
                            dtmp = 'DICT'
                        endif
                        write(iun,1001) 
     &                  i,stmp,(coo(j,i)*toang,j=1,3),atmp,ires,
     &                  aminos(iamino(ires)),0.0d0,dtmp
                     else
                        write(iun,1000) 
     &                  i,atom,(coo(j,i)*toang,j=1,3),atmp,q
                     endif
                  else
                     write(iun,1000) 
     &                  i,atom,(coo(j,i)*toang,j=1,3),atmp,q
                  endif
               endif
            end do

         endif

      endif


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

      ibnds = 1

      if (ipdbon.eq.1) then

         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)
                     kt = iamap(k)
                     it = iamap(i)
                     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,it,kt,'    ar'
                     else
                        write(iun,'(4(i6,1x))') ibnds,it,kt,ibt
                     endif
                     ibnds = ibnds + 1
                  endif
               endif
            end do
         end do

      else

         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

      endif

      write(iun,'(a)') '@<TRIPOS>SUBSTRUCTURE'
      if (ipdbon.eq.1) then
         irs = 0
         do i=1,ncalf
            irs = irs + 1
            write(iun,'(i5,1x,a4,i5,a,a3)') 
     &       i,aminos(iamino(i))//' ',iamap(icalf(1,i)),
     &       ' RESIDUE    1 A   ',aminos(iamino(i))
         end do
         igrp = 0
         ireso = 0
         do i=1,natoms
            ires = iresid(i)
            if (ires.lt.-3.and.ires.ne.-ishoh) then
               if (ires.ne.ireso) then
                  ireso = ires
                  irs = irs + 1
                  igrp = igrp + 1
                  stmp = 'GRP'//char(48+igrp)
                  write(iun,'(i5,1x,a4,i5,a)') 
     &             irs,stmp,iamap(i),
     &             ' GROUP      0 A     ****    0 ROOT'
               endif
            endif
         end do
      else
         write(iun,*) '     1 RES1       1'
      endif

      if (icel.eq.1) then
         write(iun,'(a)') '@<TRIPOS>CRYSIN'
         write(iun,'(6(f10.4,1x),i3,1x,i1)') 
     &         a,b,c,alpha/torad,beta/torad,gamma/torad,nspg,1
      endif

      call chkmol2(iok)
      if (iok.eq.0) call messg(17)
      if (jflg.eq.1) call messg(15)

      if (icel.eq.1) call fdat(1,0,0,0,0,0)

      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

