source/unres/src_MD-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       include 'COMMON.DISTFIT'
  11       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       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
  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         iti=itype(i)
  94         if (iti.eq.21) then
  95           ichain=ichain+1
  96           ires=0
  97           write (iunit,'(a)') 'TER'
  98         else
  99         ires=ires+1
 100         iatom=iatom+1
 101         ica(i)=iatom
 102         write (iunit,10) iatom,restyp(iti),chainid(ichain),
 103      &     ires,(c(j,i),j=1,3),vtot(i)
 104         if (iti.ne.10) then
 105           iatom=iatom+1
 106           write (iunit,20) iatom,restyp(iti),chainid(ichain),
 107      &      ires,(c(j,nres+i),j=1,3),
 108      &      vtot(i+nres)
 109         endif
 110         endif
 111       enddo
 112       write (iunit,'(a)') 'TER'
 113       do i=nnt,nct-1
 114         if (itype(i).eq.21) cycle
 115         if (itype(i).eq.10 .and. itype(i+1).ne.21) then
 116           write (iunit,30) ica(i),ica(i+1)
 117         else if (itype(i).ne.10 .and. itype(i+1).ne.21) then
 118           write (iunit,30) ica(i),ica(i+1),ica(i)+1
 119         else if (itype(i).ne.10 .and. itype(i+1).eq.21) then
 120           write (iunit,30) ica(i),ica(i)+1
 121         endif
 122       enddo
 123       if (itype(nct).ne.10) then
 124         write (iunit,30) ica(nct),ica(nct)+1
 125       endif
 126       do i=1,nss
 127         write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
 128       enddo
 129       write (iunit,'(a6)') 'ENDMDL'
 130   10  FORMAT ('ATOM',I7,'  CA  ',A3,1X,A1,I4,4X,3F8.3,f15.3)
 131   20  FORMAT ('ATOM',I7,'  CB  ',A3,1X,A1,I4,4X,3F8.3,f15.3)
 132   30  FORMAT ('CONECT',8I5)
 133       return
 134       end
 135 c------------------------------------------------------------------------------
 136       subroutine MOL2out(etot,tytul)
 137 C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2
 138 C format.
 139       implicit real*8 (a-h,o-z)
 140       include 'DIMENSIONS'
 141       include 'COMMON.CHAIN'
 142       include 'COMMON.INTERACT'
 143       include 'COMMON.NAMES'
 144       include 'COMMON.IOUNITS'
 145       include 'COMMON.HEADER'
 146       include 'COMMON.SBRIDGE'
 147       character*32 tytul,fd
 148       character*3 zahl
 149       character*6 res_num,pom,ucase
 150 #ifdef AIX
 151       call fdate_(fd)
 152 #elif (defined CRAY)
 153       call date(fd)
 154 #else
 155       call fdate(fd)
 156 #endif
 157       write (imol2,'(a)') '#'
 158       write (imol2,'(a)')
 159      & '#         Creating user name:           unres'
 160       write (imol2,'(2a)') '#         Creation time:                ',
 161      & fd
 162       write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
 163       write (imol2,'(a)') tytul
 164       write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
 165       write (imol2,'(a)') 'SMALL'
 166       write (imol2,'(a)') 'USER_CHARGES'
 167       write (imol2,'(a)') '\@<TRIPOS>ATOM'
 168       do i=nnt,nct
 169         write (zahl,'(i3)') i
 170         pom=ucase(restyp(itype(i)))
 171         res_num = pom(:3)//zahl(2:)
 172         write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
 173       enddo
 174       write (imol2,'(a)') '\@<TRIPOS>BOND'
 175       do i=nnt,nct-1
 176         write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
 177       enddo
 178       do i=1,nss
 179         write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
 180       enddo
 181       write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
 182       do i=nnt,nct
 183         write (zahl,'(i3)') i
 184         pom = ucase(restyp(itype(i)))
 185         res_num = pom(:3)//zahl(2:)
 186         write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
 187       enddo
 188   10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
 189   30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
 190       return
 191       end
 192 c------------------------------------------------------------------------
 193       subroutine intout
 194       implicit real*8 (a-h,o-z)
 195       include 'DIMENSIONS'
 196       include 'COMMON.IOUNITS'
 197       include 'COMMON.CHAIN'
 198       include 'COMMON.VAR'
 199       include 'COMMON.LOCAL'
 200       include 'COMMON.INTERACT'
 201       include 'COMMON.NAMES'
 202       include 'COMMON.GEO'
 203       write (iout,'(/a)') 'Geometry of the virtual chain.'
 204       write (iout,'(7a)') '  Res  ','         d','     Theta',
 205      & '       Phi','       Dsc','     Alpha','      Omega'
 206       do i=1,nres
 207         iti=itype(i)
 208         write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i),
 209      &     rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),
 210      &     rad2deg*omeg(i)
 211       enddo
 212       return
 213       end
 214 c---------------------------------------------------------------------------
 215       subroutine briefout(it,ener)
 216       implicit real*8 (a-h,o-z)
 217       include 'DIMENSIONS'
 218       include 'COMMON.IOUNITS'
 219       include 'COMMON.CHAIN'
 220       include 'COMMON.VAR'
 221       include 'COMMON.LOCAL'
 222       include 'COMMON.INTERACT'
 223       include 'COMMON.NAMES'
 224       include 'COMMON.GEO'
 225       include 'COMMON.SBRIDGE'
 226 c     print '(a,i5)',intname,igeom
 227 #if defined(AIX) || defined(PGI)
 228       open (igeom,file=intname,position='append')
 229 #else
 230       open (igeom,file=intname,access='append')
 231 #endif
 232       IF (NSS.LE.9) THEN
 233         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
 234       ELSE
 235         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
 236         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
 237       ENDIF
 238 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 239       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 240       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
 241 c     if (nvar.gt.nphi+ntheta) then
 242         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
 243         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
 244 c     endif
 245       close(igeom)
 246   180 format (I5,F12.3,I2,9(1X,2I3))
 247   190 format (3X,11(1X,2I3))
 248   200 format (8F10.4)
 249       return
 250       end
 251 #ifdef WINIFL
 252       subroutine fdate(fd)
 253       character*32 fd
 254       write(fd,'(32x)')
 255       return
 256       end
 257 #endif
 258 c----------------------------------------------------------------
 259 #ifdef NOXDR
 260       subroutine cartout(time)
 261 #else
 262       subroutine cartoutx(time)
 263 #endif
 264       implicit real*8 (a-h,o-z)
 265       include 'DIMENSIONS'
 266       include 'COMMON.CHAIN'
 267       include 'COMMON.INTERACT'
 268       include 'COMMON.NAMES'
 269       include 'COMMON.IOUNITS'
 270       include 'COMMON.HEADER'
 271       include 'COMMON.SBRIDGE'
 272       include 'COMMON.DISTFIT'
 273       include 'COMMON.MD'
 274       double precision time
 275 #if defined(AIX) || defined(PGI)
 276       open(icart,file=cartname,position="append")
 277 #else
 278       open(icart,file=cartname,access="append")
 279 #endif
 280       write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath
 281       write (icart,'(i4,$)')
 282      &   nss,(ihpb(j),jhpb(j),j=1,nss)
 283        write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back,
 284      & (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair),
 285      & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
 286       write (icart,'(8f10.5)')
 287      & ((c(k,j),k=1,3),j=1,nres),
 288      & ((c(k,j+nres),k=1,3),j=nnt,nct)
 289       close(icart)
 290       return
 291       end
 292 c-----------------------------------------------------------------
 293 #ifndef NOXDR
 294       subroutine cartout(time)
 295       implicit real*8 (a-h,o-z)
 296       include 'DIMENSIONS'
 297 #ifdef MPI
 298       include 'mpif.h'
 299       include 'COMMON.SETUP'
 300 #else
 301       parameter (me=0)
 302 #endif
 303       include 'COMMON.CHAIN'
 304       include 'COMMON.INTERACT'
 305       include 'COMMON.NAMES'
 306       include 'COMMON.IOUNITS'
 307       include 'COMMON.HEADER'
 308       include 'COMMON.SBRIDGE'
 309       include 'COMMON.DISTFIT'
 310       include 'COMMON.MD'
 311       double precision time
 312       integer iret,itmp
 313       real xcoord(3,maxres2+2),prec
 314
 315 #ifdef AIX
 316       call xdrfopen_(ixdrf,cartname, "a", iret)
 317       call xdrffloat_(ixdrf, real(time), iret)
 318       call xdrffloat_(ixdrf, real(potE), iret)
 319       call xdrffloat_(ixdrf, real(uconst), iret)
 320       call xdrffloat_(ixdrf, real(uconst_back), iret)
 321       call xdrffloat_(ixdrf, real(t_bath), iret)
 322       call xdrfint_(ixdrf, nss, iret)
 323       do j=1,nss
 324         call xdrfint_(ixdrf, ihpb(j), iret)
 325         call xdrfint_(ixdrf, jhpb(j), iret)
 326       enddo
 327       call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret)
 328       do i=1,nfrag
 329         call xdrffloat_(ixdrf, real(qfrag(i)), iret)
 330       enddo
 331       do i=1,npair
 332         call xdrffloat_(ixdrf, real(qpair(i)), iret)
 333       enddo
 334       do i=1,nfrag_back
 335         call xdrffloat_(ixdrf, real(utheta(i)), iret)
 336         call xdrffloat_(ixdrf, real(ugamma(i)), iret)
 337         call xdrffloat_(ixdrf, real(uscdiff(i)), iret)
 338       enddo
 339 #else
 340       call xdrfopen(ixdrf,cartname, "a", iret)
 341       call xdrffloat(ixdrf, real(time), iret)
 342       call xdrffloat(ixdrf, real(potE), iret)
 343       call xdrffloat(ixdrf, real(uconst), iret)
 344       call xdrffloat(ixdrf, real(uconst_back), iret)
 345       call xdrffloat(ixdrf, real(t_bath), iret)
 346       call xdrfint(ixdrf, nss, iret)
 347       do j=1,nss
 348         call xdrfint(ixdrf, ihpb(j), iret)
 349         call xdrfint(ixdrf, jhpb(j), iret)
 350       enddo
 351       call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret)
 352       do i=1,nfrag
 353         call xdrffloat(ixdrf, real(qfrag(i)), iret)
 354       enddo
 355       do i=1,npair
 356         call xdrffloat(ixdrf, real(qpair(i)), iret)
 357       enddo
 358       do i=1,nfrag_back
 359         call xdrffloat(ixdrf, real(utheta(i)), iret)
 360         call xdrffloat(ixdrf, real(ugamma(i)), iret)
 361         call xdrffloat(ixdrf, real(uscdiff(i)), iret)
 362       enddo
 363 #endif
 364       prec=10000.0
 365       do i=1,nres
 366        do j=1,3
 367         xcoord(j,i)=c(j,i)
 368        enddo
 369       enddo
 370       do i=nnt,nct
 371        do j=1,3
 372         xcoord(j,nres+i-nnt+1)=c(j,i+nres)
 373        enddo
 374       enddo
 375
 376       itmp=nres+nct-nnt+1
 377 #ifdef AIX
 378       call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret)
 379       call xdrfclose_(ixdrf, iret)
 380 #else
 381       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
 382       call xdrfclose(ixdrf, iret)
 383 #endif
 384       return
 385       end
 386 #endif
 387 c-----------------------------------------------------------------
 388       subroutine statout(itime)
 389       implicit real*8 (a-h,o-z)
 390       include 'DIMENSIONS'
 391       include 'COMMON.CONTROL'
 392       include 'COMMON.CHAIN'
 393       include 'COMMON.INTERACT'
 394       include 'COMMON.NAMES'
 395       include 'COMMON.IOUNITS'
 396       include 'COMMON.HEADER'
 397       include 'COMMON.SBRIDGE'
 398       include 'COMMON.DISTFIT'
 399       include 'COMMON.MD'
 400       include 'COMMON.SETUP'
 401       integer itime
 402       double precision energia(0:n_ene)
 403       double precision gyrate
 404       external gyrate
 405       common /gucio/ cm
 406       character*256 line1,line2
 407       character*4 format1,format2
 408       character*30 format
 409 #ifdef AIX
 410       if(itime.eq.0) then
 411        open(istat,file=statname,position="append")
 412       endif
 413 #else
 414 #ifdef PGI
 415       open(istat,file=statname,position="append")
 416 #else
 417       open(istat,file=statname,access="append")
 418 #endif
 419 #endif
 420        if (refstr) then
 421          call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
 422           write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)')
 423      &          itime,totT,EK,potE,totE,
 424      &          rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
 425           format1="a133"
 426         else
 427           write (line1,'(i10,f15.2,7f12.3,i5,$)')
 428      &           itime,totT,EK,potE,totE,
 429      &           amax,kinetic_T,t_bath,gyrate(),me
 430           format1="a114"
 431         endif
 432         if(usampl.and.totT.gt.eq_time) then
 433            write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,
 434      &      (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),
 435      &      (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
 436            write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair
 437      &             +21*nfrag_back
 438         else
 439            format2="a001"
 440            line2=' '
 441         endif
 442         if (print_compon) then
 443           write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
 444      &                                                     ",20f12.3)"
 445           write (istat,format) line1,line2,
 446      &      (potEcomp(print_order(i)),i=1,nprint_ene)
 447         else
 448           write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")"
 449           write (istat,format) line1,line2
 450         endif
 451 #if defined(AIX)
 452         call flush(istat)
 453 #else
 454         close(istat)
 455 #endif
 456        return
 457       end
 458 c---------------------------------------------------------------
 459       double precision function gyrate()
 460       implicit real*8 (a-h,o-z)
 461       include 'DIMENSIONS'
 462       include 'COMMON.INTERACT'
 463       include 'COMMON.CHAIN'
 464       double precision cen(3),rg
 465
 466       do j=1,3
 467        cen(j)=0.0d0
 468       enddo
 469
 470       do i=nnt,nct
 471           do j=1,3
 472             cen(j)=cen(j)+c(j,i)
 473           enddo
 474       enddo
 475       do j=1,3
 476             cen(j)=cen(j)/dble(nct-nnt+1)
 477       enddo
 478       rg = 0.0d0
 479       do i = nnt, nct
 480         do j=1,3
 481          rg = rg + (c(j,i)-cen(j))**2
 482         enddo
 483       end do
 484       gyrate = sqrt(rg/dble(nct-nnt+1))
 485       return
 486       end
 487