source/xdrfpdb/src/geomout.F

   1       subroutine pdbout(etot,tytul,iunit)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'COMMON.CHAIN'
   5       include 'COMMON.INTERACT'
   6       include 'COMMON.NAMES'
   7       include 'COMMON.IOUNITS'
   8       include 'COMMON.HEADER'
   9       include 'COMMON.SBRIDGE'
  10 c      include 'COMMON.DISTFIT'
  11 c      include 'COMMON.MD'
  12       character*50 tytul
  13       dimension ica(maxres)
  14       write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot
  15 cmodel      write (iunit,'(a5,i6)') 'MODEL',1
  16 c      if (nhfrag.gt.0) then
  17 c       do j=1,nhfrag
  18 c        iti=itype(hfrag(1,j))
  19 c        itj=itype(hfrag(2,j))
  20 c        if (j.lt.10) then
  21 c           write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)')
  22 c     &           'HELIX',j,'H',j,
  23 c     &           restyp(iti),hfrag(1,j)-1,
  24 c     &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
  25 c        else
  26 c             write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)')
  27 c     &           'HELIX',j,'H',j,
  28 c     &           restyp(iti),hfrag(1,j)-1,
  29 c     &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
  30 c        endif
  31 c       enddo
  32 c      endif
  33
  34 c      if (nbfrag.gt.0) then
  35 c
  36 c       do j=1,nbfrag
  37 c
  38 c        iti=itype(bfrag(1,j))
  39 c        itj=itype(bfrag(2,j)-1)
  40 c
  41 c        write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)')
  42 c     &           'SHEET',1,'B',j,2,
  43 c     &           restyp(iti),bfrag(1,j)-1,
  44 c     &           restyp(itj),bfrag(2,j)-2,0
  45 c
  46 c        if (bfrag(3,j).gt.bfrag(4,j)) then
  47 c
  48 c         itk=itype(bfrag(3,j))
  49 c         itl=itype(bfrag(4,j)+1)
  50 c
  51 c         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
  52 c     &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)')
  53 c     &           'SHEET',2,'B',j,2,
  54 c     &           restyp(itl),bfrag(4,j),
  55 c     &           restyp(itk),bfrag(3,j)-1,-1,
  56 c     &           "N",restyp(itk),bfrag(3,j)-1,
  57 c     &           "O",restyp(iti),bfrag(1,j)-1
  58 c
  59 c        else
  60 c
  61 c         itk=itype(bfrag(3,j))
  62 c         itl=itype(bfrag(4,j)-1)
  63 c
  64 c
  65 c        write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
  66 c     &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)')
  67 c     &           'SHEET',2,'B',j,2,
  68 c     &           restyp(itk),bfrag(3,j)-1,
  69 c     &           restyp(itl),bfrag(4,j)-2,1,
  70 c     &           "N",restyp(itk),bfrag(3,j)-1,
  71 c     &           "O",restyp(iti),bfrag(1,j)-1
  72 c
  73 c
  74 c
  75 c        endif
  76 c
  77 c       enddo
  78 c      endif
  79
  80       if (nss.gt.0) then
  81         do i=1,nss
  82           write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)')
  83      &         'SSBOND',i,'CYS',ihpb(i)-1-nres,
  84      &                    'CYS',jhpb(i)-1-nres
  85         enddo
  86       endif
  87
  88       iatom=0
  89       do i=nnt,nct
  90         ires=i-nnt+1
  91         iatom=iatom+1
  92         ica(i)=iatom
  93         iti=itype(i)
  94         write (iunit,10) iatom,restyp(iti),ires,(c(j,i),j=1,3)!,vtot(i)
  95         if (iti.ne.10) then
  96           iatom=iatom+1
  97           write (iunit,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3)!,
  98 !     &      vtot(i+nres)
  99         endif
 100       enddo
 101       write (iunit,'(a)') 'TER'
 102       do i=nnt,nct-1
 103         if (itype(i).eq.10) then
 104           write (iunit,30) ica(i),ica(i+1)
 105         else
 106           write (iunit,30) ica(i),ica(i+1),ica(i)+1
 107         endif
 108       enddo
 109       if (itype(nct).ne.10) then
 110         write (iunit,30) ica(nct),ica(nct)+1
 111       endif
 112       do i=1,nss
 113         write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
 114       enddo
 115       write (iunit,'(a6)') 'ENDMDL'
 116   10  FORMAT ('ATOM',I7,'  CA  ',A3,I6,4X,3F8.3,f15.3)
 117   20  FORMAT ('ATOM',I7,'  CB  ',A3,I6,4X,3F8.3,f15.3)
 118   30  FORMAT ('CONECT',8I5)
 119       return
 120       end
 121 c------------------------------------------------------------------------------
 122       subroutine MOL2out(etot,tytul)
 123 C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2
 124 C format.
 125       implicit real*8 (a-h,o-z)
 126       include 'DIMENSIONS'
 127       include 'COMMON.CHAIN'
 128       include 'COMMON.INTERACT'
 129       include 'COMMON.NAMES'
 130       include 'COMMON.IOUNITS'
 131       include 'COMMON.HEADER'
 132       include 'COMMON.SBRIDGE'
 133       character*32 tytul,fd
 134       character*3 liczba
 135       character*6 res_num,pom,ucase
 136 #ifdef AIX
 137       call fdate_(fd)
 138 #elif (defined CRAY)
 139       call date(fd)
 140 #else
 141       call fdate(fd)
 142 #endif
 143       write (imol2,'(a)') '#'
 144       write (imol2,'(a)')
 145      & '#         Creating user name:           unres'
 146       write (imol2,'(2a)') '#         Creation time:                ',
 147      & fd
 148       write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
 149       write (imol2,'(a)') tytul
 150       write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
 151       write (imol2,'(a)') 'SMALL'
 152       write (imol2,'(a)') 'USER_CHARGES'
 153       write (imol2,'(a)') '\@<TRIPOS>ATOM'
 154       do i=nnt,nct
 155         write (liczba,'(i3)') i
 156         pom=ucase(restyp(itype(i)))
 157         res_num = pom(:3)//liczba(2:)
 158         write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
 159       enddo
 160       write (imol2,'(a)') '\@<TRIPOS>BOND'
 161       do i=nnt,nct-1
 162         write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
 163       enddo
 164       do i=1,nss
 165         write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
 166       enddo
 167       write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
 168       do i=nnt,nct
 169         write (liczba,'(i3)') i
 170         pom = ucase(restyp(itype(i)))
 171         res_num = pom(:3)//liczba(2:)
 172         write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
 173       enddo
 174   10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
 175   30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
 176       return
 177       end
 178 c------------------------------------------------------------------------
 179       subroutine briefout(it,ener)
 180       implicit real*8 (a-h,o-z)
 181       include 'DIMENSIONS'
 182       include 'COMMON.IOUNITS'
 183       include 'COMMON.CHAIN'
 184       include 'COMMON.VAR'
 185       include 'COMMON.LOCAL'
 186       include 'COMMON.INTERACT'
 187       include 'COMMON.NAMES'
 188       include 'COMMON.GEO'
 189       include 'COMMON.SBRIDGE'
 190 c     print '(a,i5)',intname,igeom
 191 #if defined(AIX) || defined(PGI)
 192       open (igeom,file=intname,position='append')
 193 #else
 194       open (igeom,file=intname,access='append')
 195 #endif
 196       IF (NSS.LE.9) THEN
 197         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
 198       ELSE
 199         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
 200         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
 201       ENDIF
 202 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 203       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 204       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
 205 c     if (nvar.gt.nphi+ntheta) then
 206         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
 207         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
 208 c     endif
 209       close(igeom)
 210   180 format (I5,F12.3,I2,9(1X,2I3))
 211   190 format (3X,11(1X,2I3))
 212   200 format (8F10.4)
 213       return
 214       end
 215 #ifdef WINIFL
 216       subroutine fdate(fd)
 217       character*32 fd
 218       write(fd,'(32x)')
 219       return
 220       end
 221 #endif
 222 c----------------------------------------------------------------
 223       subroutine cartoutx(time,nfrag,qfrag)
 224       implicit real*8 (a-h,o-z)
 225       include 'DIMENSIONS'
 226       include 'COMMON.CHAIN'
 227       include 'COMMON.INTERACT'
 228       include 'COMMON.NAMES'
 229       include 'COMMON.IOUNITS'
 230       include 'COMMON.HEADER'
 231       include 'COMMON.SBRIDGE'
 232       include 'COMMON.DISTFIT'
 233 c      include 'COMMON.MD'
 234       double precision time
 235       double precision qfrag(100)
 236 #if defined(AIX) || defined(PGI)
 237       open(icart,file=cartname,position="append")
 238 #else
 239       open(icart,file=cartname,access="append")
 240 #endif
 241       write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath
 242       write (icart,'(i4,$)')
 243      &   nss,(ihpb(j),jhpb(j),j=1,nss)
 244        write (icart,'(i4,20f7.4)') nfrag,
 245      & (qfrag(i),i=1,nfrag)
 246       write (icart,'(8f10.5)')
 247      & ((c(k,j),k=1,3),j=1,nres),
 248      & ((c(k,j+nres),k=1,3),j=nnt,nct)
 249       close(icart)
 250       return
 251       end
 252 c-----------------------------------------------------------------
 253       subroutine cartout(time,nfrag,qfrag)
 254       implicit real*8 (a-h,o-z)
 255       include 'DIMENSIONS'
 256       include 'COMMON.CHAIN'
 257       include 'COMMON.INTERACT'
 258       include 'COMMON.NAMES'
 259       include 'COMMON.IOUNITS'
 260       include 'COMMON.HEADER'
 261       include 'COMMON.SBRIDGE'
 262       include 'COMMON.DISTFIT'
 263 c      include 'COMMON.MD'
 264       double precision time
 265       integer iret,itmp
 266       double precision qfrag(100)
 267       real xcoord(3,maxres2+2),prec
 268
 269       call xdrfopen(ixdrf,cartname, "w", iret)
 270       call xdrffloat(ixdrf, real(time), iret)
 271       call xdrffloat(ixdrf, real(potE), iret)
 272       call xdrffloat(ixdrf, real(uconst), iret)
 273       call xdrffloat(ixdrf, real(t_bath), iret)
 274       call xdrfint(ixdrf, nss, iret)
 275       do j=1,nss
 276         call xdrfint(ixdrf, ihpb(j), iret)
 277         call xdrfint(ixdrf, jhpb(j), iret)
 278       enddo
 279       call xdrfint(ixdrf, nfrag, iret)
 280       do i=1,nfrag
 281         call xdrffloat(ixdrf, real(qfrag(i)), iret)
 282       enddo
 283       prec=10000.0
 284       do i=1,nres
 285        do j=1,3
 286         xcoord(j,i)=c(j,i)
 287        enddo
 288       enddo
 289       do i=nnt,nct
 290        do j=1,3
 291         xcoord(j,nres+i-nnt+1)=c(j,i+nres)
 292        enddo
 293       enddo
 294
 295       itmp=nres+nct-nnt+1
 296       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
 297       call xdrfclose(ixdrf, iret)
 298       return
 299       end