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