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