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