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           if (iti_prev.ne.ntyp1) 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         iti_prev=iti
 117       enddo
 118       write (iunit,'(a)') 'TER'
 119       do i=nnt,nct-1
 120         if (itype(i).eq.ntyp1) cycle
 121         if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then
 122           write (iunit,30) ica(i),ica(i+1)
 123         else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then
 124           write (iunit,30) ica(i),ica(i+1),ica(i)+1
 125         else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then
 126           write (iunit,30) ica(i),ica(i)+1
 127         endif
 128       enddo
 129       if (itype(nct).ne.10) then
 130         write (iunit,30) ica(nct),ica(nct)+1
 131       endif
 132       do i=1,nss
 133         write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
 134       enddo
 135       write (iunit,'(a6)') 'ENDMDL'
 136   10  FORMAT ('ATOM',I7,'  CA  ',A3,1X,A1,I4,4X,3F8.3,f15.3)
 137   20  FORMAT ('ATOM',I7,'  CB  ',A3,1X,A1,I4,4X,3F8.3,f15.3)
 138   30  FORMAT ('CONECT',8I5)
 139       return
 140       end
 141 c------------------------------------------------------------------------------
 142       subroutine MOL2out(etot,tytul)
 143 C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2
 144 C format.
 145       implicit real*8 (a-h,o-z)
 146       include 'DIMENSIONS'
 147       include 'COMMON.CHAIN'
 148       include 'COMMON.INTERACT'
 149       include 'COMMON.NAMES'
 150       include 'COMMON.IOUNITS'
 151       include 'COMMON.HEADER'
 152       include 'COMMON.SBRIDGE'
 153       character*32 tytul,fd
 154       character*3 liczba
 155       character*6 res_num,pom,ucase
 156 #ifdef AIX
 157       call fdate_(fd)
 158 #elif (defined CRAY)
 159       call date(fd)
 160 #else
 161       call fdate(fd)
 162 #endif
 163       write (imol2,'(a)') '#'
 164       write (imol2,'(a)')
 165      & '#         Creating user name:           unres'
 166       write (imol2,'(2a)') '#         Creation time:                ',
 167      & fd
 168       write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
 169       write (imol2,'(a)') tytul
 170       write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
 171       write (imol2,'(a)') 'SMALL'
 172       write (imol2,'(a)') 'USER_CHARGES'
 173       write (imol2,'(a)') '\@<TRIPOS>ATOM'
 174       do i=nnt,nct
 175         write (liczba,'(i3)') i
 176         pom=ucase(restyp(itype(i)))
 177         res_num = pom(:3)//liczba(2:)
 178         write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
 179       enddo
 180       write (imol2,'(a)') '\@<TRIPOS>BOND'
 181       do i=nnt,nct-1
 182         write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
 183       enddo
 184       do i=1,nss
 185         write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
 186       enddo
 187       write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
 188       do i=nnt,nct
 189         write (liczba,'(i3)') i
 190         pom = ucase(restyp(itype(i)))
 191         res_num = pom(:3)//liczba(2:)
 192         write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
 193       enddo
 194   10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
 195   30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
 196       return
 197       end
 198 c------------------------------------------------------------------------
 199       subroutine briefout(it,ener)
 200       implicit real*8 (a-h,o-z)
 201       include 'DIMENSIONS'
 202       include 'COMMON.IOUNITS'
 203       include 'COMMON.CHAIN'
 204       include 'COMMON.VAR'
 205       include 'COMMON.LOCAL'
 206       include 'COMMON.INTERACT'
 207       include 'COMMON.NAMES'
 208       include 'COMMON.GEO'
 209       include 'COMMON.SBRIDGE'
 210 c     print '(a,i5)',intname,igeom
 211 #if defined(AIX) || defined(PGI)
 212       open (igeom,file=intname,position='append')
 213 #else
 214       open (igeom,file=intname,access='append')
 215 #endif
 216       IF (NSS.LE.9) THEN
 217         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
 218       ELSE
 219         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
 220         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
 221       ENDIF
 222 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 223       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 224       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
 225 c     if (nvar.gt.nphi+ntheta) then
 226         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
 227         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
 228 c     endif
 229       close(igeom)
 230   180 format (I5,F12.3,I2,9(1X,2I3))
 231   190 format (3X,11(1X,2I3))
 232   200 format (8F10.4)
 233       return
 234       end
 235 #ifdef WINIFL
 236       subroutine fdate(fd)
 237       character*32 fd
 238       write(fd,'(32x)')
 239       return
 240       end
 241 #endif
 242 c----------------------------------------------------------------
 243       subroutine cartoutx(time,nfrag,qfrag)
 244       implicit real*8 (a-h,o-z)
 245       include 'DIMENSIONS'
 246       include 'COMMON.CHAIN'
 247       include 'COMMON.INTERACT'
 248       include 'COMMON.NAMES'
 249       include 'COMMON.IOUNITS'
 250       include 'COMMON.HEADER'
 251       include 'COMMON.SBRIDGE'
 252       include 'COMMON.DISTFIT'
 253 c      include 'COMMON.MD'
 254       double precision time
 255       double precision qfrag(100)
 256 #if defined(AIX) || defined(PGI)
 257       open(icart,file=cartname,position="append")
 258 #else
 259       open(icart,file=cartname,access="append")
 260 #endif
 261       write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath
 262       write (icart,'(i4,$)')
 263      &   nss,(ihpb(j),jhpb(j),j=1,nss)
 264        write (icart,'(i4,20f7.4)') nfrag,
 265      & (qfrag(i),i=1,nfrag)
 266       write (icart,'(8f10.5)')
 267      & ((c(k,j),k=1,3),j=1,nres),
 268      & ((c(k,j+nres),k=1,3),j=nnt,nct)
 269       close(icart)
 270       return
 271       end
 272 c-----------------------------------------------------------------
 273       subroutine cartout(time,nfrag,qfrag)
 274       implicit real*8 (a-h,o-z)
 275       include 'DIMENSIONS'
 276       include 'COMMON.CHAIN'
 277       include 'COMMON.INTERACT'
 278       include 'COMMON.NAMES'
 279       include 'COMMON.IOUNITS'
 280       include 'COMMON.HEADER'
 281       include 'COMMON.SBRIDGE'
 282       include 'COMMON.DISTFIT'
 283 c      include 'COMMON.MD'
 284       double precision time
 285       integer iret,itmp
 286       double precision qfrag(100)
 287       real xcoord(3,maxres2+2),prec
 288
 289       call xdrfopen(ixdrf,cartname, "w", iret)
 290       call xdrffloat(ixdrf, real(time), iret)
 291       call xdrffloat(ixdrf, real(potE), iret)
 292       call xdrffloat(ixdrf, real(uconst), iret)
 293       call xdrffloat(ixdrf, real(t_bath), iret)
 294       call xdrfint(ixdrf, nss, iret)
 295       do j=1,nss
 296         call xdrfint(ixdrf, ihpb(j), iret)
 297         call xdrfint(ixdrf, jhpb(j), iret)
 298       enddo
 299       call xdrfint(ixdrf, nfrag, iret)
 300       do i=1,nfrag
 301         call xdrffloat(ixdrf, real(qfrag(i)), iret)
 302       enddo
 303       prec=10000.0
 304       do i=1,nres
 305        do j=1,3
 306         xcoord(j,i)=c(j,i)
 307        enddo
 308       enddo
 309       do i=nnt,nct
 310        do j=1,3
 311         xcoord(j,nres+i-nnt+1)=c(j,i+nres)
 312        enddo
 313       enddo
 314
 315       itmp=nres+nct-nnt+1
 316       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
 317       call xdrfclose(ixdrf, iret)
 318       return
 319       end