source/unres/src_MD/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       dimension ica(maxres)
  14       write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot
  15 cmodel      write (iunit,'(a5,i6)') 'MODEL',1
  16       if (nhfrag.gt.0) then
  17        do j=1,nhfrag
  18         iti=itype(hfrag(1,j))
  19         itj=itype(hfrag(2,j))
  20         if (j.lt.10) then
  21            write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)')
  22      &           'HELIX',j,'H',j,
  23      &           restyp(iti),hfrag(1,j)-1,
  24      &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
  25         else
  26              write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)')
  27      &           'HELIX',j,'H',j,
  28      &           restyp(iti),hfrag(1,j)-1,
  29      &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
  30         endif
  31        enddo
  32       endif
  33
  34       if (nbfrag.gt.0) then
  35
  36        do j=1,nbfrag
  37
  38         iti=itype(bfrag(1,j))
  39         itj=itype(bfrag(2,j)-1)
  40
  41         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)')
  42      &           'SHEET',1,'B',j,2,
  43      &           restyp(iti),bfrag(1,j)-1,
  44      &           restyp(itj),bfrag(2,j)-2,0
  45
  46         if (bfrag(3,j).gt.bfrag(4,j)) then
  47
  48          itk=itype(bfrag(3,j))
  49          itl=itype(bfrag(4,j)+1)
  50
  51          write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
  52      &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)')
  53      &           'SHEET',2,'B',j,2,
  54      &           restyp(itl),bfrag(4,j),
  55      &           restyp(itk),bfrag(3,j)-1,-1,
  56      &           "N",restyp(itk),bfrag(3,j)-1,
  57      &           "O",restyp(iti),bfrag(1,j)-1
  58
  59         else
  60
  61          itk=itype(bfrag(3,j))
  62          itl=itype(bfrag(4,j)-1)
  63
  64
  65         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
  66      &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)')
  67      &           'SHEET',2,'B',j,2,
  68      &           restyp(itk),bfrag(3,j)-1,
  69      &           restyp(itl),bfrag(4,j)-2,1,
  70      &           "N",restyp(itk),bfrag(3,j)-1,
  71      &           "O",restyp(iti),bfrag(1,j)-1
  72
  73
  74
  75         endif
  76
  77        enddo
  78       endif
  79
  80       if (nss.gt.0) then
  81         do i=1,nss
  82          if (dyn_ss) then
  83           write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)')
  84      &         'SSBOND',i,'CYS',idssb(i)-nnt+1,
  85      &                    'CYS',jdssb(i)-nnt+1
  86          else
  87           write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)')
  88      &         'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres,
  89      &                    'CYS',jhpb(i)-nnt+1-nres
  90          endif
  91         enddo
  92       endif
  93
  94       iatom=0
  95       do i=nnt,nct
  96         ires=i-nnt+1
  97         iatom=iatom+1
  98         ica(i)=iatom
  99         iti=itype(i)
 100         write (iunit,10) iatom,restyp(iti),ires,(c(j,i),j=1,3),vtot(i)
 101         if (iti.ne.10) then
 102           iatom=iatom+1
 103           write (iunit,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3),
 104      &      vtot(i+nres)
 105         endif
 106       enddo
 107       write (iunit,'(a)') 'TER'
 108       do i=nnt,nct-1
 109         if (itype(i).eq.10) then
 110           write (iunit,30) ica(i),ica(i+1)
 111         else
 112           write (iunit,30) ica(i),ica(i+1),ica(i)+1
 113         endif
 114       enddo
 115       if (itype(nct).ne.10) then
 116         write (iunit,30) ica(nct),ica(nct)+1
 117       endif
 118       do i=1,nss
 119        if (dyn_ss) then
 120         write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1
 121        else
 122         write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
 123        endif
 124       enddo
 125       write (iunit,'(a6)') 'ENDMDL'
 126   10  FORMAT ('ATOM',I7,'  CA  ',A3,I6,4X,3F8.3,f15.3)
 127   20  FORMAT ('ATOM',I7,'  CB  ',A3,I6,4X,3F8.3,f15.3)
 128   30  FORMAT ('CONECT',8I5)
 129       return
 130       end
 131 c------------------------------------------------------------------------------
 132       subroutine MOL2out(etot,tytul)
 133 C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2
 134 C format.
 135       implicit real*8 (a-h,o-z)
 136       include 'DIMENSIONS'
 137       include 'COMMON.CHAIN'
 138       include 'COMMON.INTERACT'
 139       include 'COMMON.NAMES'
 140       include 'COMMON.IOUNITS'
 141       include 'COMMON.HEADER'
 142       include 'COMMON.SBRIDGE'
 143       character*32 tytul,fd
 144       character*3 zahl
 145       character*6 res_num,pom,ucase
 146 #ifdef AIX
 147       call fdate_(fd)
 148 #elif (defined CRAY)
 149       call date(fd)
 150 #else
 151       call fdate(fd)
 152 #endif
 153       write (imol2,'(a)') '#'
 154       write (imol2,'(a)')
 155      & '#         Creating user name:           unres'
 156       write (imol2,'(2a)') '#         Creation time:                ',
 157      & fd
 158       write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
 159       write (imol2,'(a)') tytul
 160       write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
 161       write (imol2,'(a)') 'SMALL'
 162       write (imol2,'(a)') 'USER_CHARGES'
 163       write (imol2,'(a)') '\@<TRIPOS>ATOM'
 164       do i=nnt,nct
 165         write (zahl,'(i3)') i
 166         pom=ucase(restyp(itype(i)))
 167         res_num = pom(:3)//zahl(2:)
 168         write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
 169       enddo
 170       write (imol2,'(a)') '\@<TRIPOS>BOND'
 171       do i=nnt,nct-1
 172         write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
 173       enddo
 174       do i=1,nss
 175         write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
 176       enddo
 177       write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
 178       do i=nnt,nct
 179         write (zahl,'(i3)') i
 180         pom = ucase(restyp(itype(i)))
 181         res_num = pom(:3)//zahl(2:)
 182         write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
 183       enddo
 184   10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
 185   30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
 186       return
 187       end
 188 c------------------------------------------------------------------------
 189       subroutine intout
 190       implicit real*8 (a-h,o-z)
 191       include 'DIMENSIONS'
 192       include 'COMMON.IOUNITS'
 193       include 'COMMON.CHAIN'
 194       include 'COMMON.VAR'
 195       include 'COMMON.LOCAL'
 196       include 'COMMON.INTERACT'
 197       include 'COMMON.NAMES'
 198       include 'COMMON.GEO'
 199       write (iout,'(/a)') 'Geometry of the virtual chain.'
 200       write (iout,'(7a)') '  Res  ','         d','     Theta',
 201      & '     Gamma','       Dsc','     Alpha','      Beta '
 202       do i=1,nres
 203         iti=itype(i)
 204         write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i),
 205      &     rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),
 206      &     rad2deg*omeg(i)
 207       enddo
 208       return
 209       end
 210 c---------------------------------------------------------------------------
 211       subroutine briefout(it,ener)
 212       implicit real*8 (a-h,o-z)
 213       include 'DIMENSIONS'
 214       include 'COMMON.IOUNITS'
 215       include 'COMMON.CHAIN'
 216       include 'COMMON.VAR'
 217       include 'COMMON.LOCAL'
 218       include 'COMMON.INTERACT'
 219       include 'COMMON.NAMES'
 220       include 'COMMON.GEO'
 221       include 'COMMON.SBRIDGE'
 222 c     print '(a,i5)',intname,igeom
 223 #if defined(AIX) || defined(PGI)
 224       open (igeom,file=intname,position='append')
 225 #else
 226       open (igeom,file=intname,access='append')
 227 #endif
 228       IF (NSS.LE.9) THEN
 229         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
 230       ELSE
 231         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
 232         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
 233       ENDIF
 234 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 235       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
 236       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
 237 c     if (nvar.gt.nphi+ntheta) then
 238         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
 239         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
 240 c     endif
 241       close(igeom)
 242   180 format (I5,F12.3,I2,9(1X,2I3))
 243   190 format (3X,11(1X,2I3))
 244   200 format (8F10.4)
 245       return
 246       end
 247 #ifdef WINIFL
 248       subroutine fdate(fd)
 249       character*32 fd
 250       write(fd,'(32x)')
 251       return
 252       end
 253 #endif
 254 c----------------------------------------------------------------
 255 #ifdef NOXDR
 256       subroutine cartout(time)
 257 #else
 258       subroutine cartoutx(time)
 259 #endif
 260       implicit real*8 (a-h,o-z)
 261       include 'DIMENSIONS'
 262       include 'COMMON.CHAIN'
 263       include 'COMMON.INTERACT'
 264       include 'COMMON.NAMES'
 265       include 'COMMON.IOUNITS'
 266       include 'COMMON.HEADER'
 267       include 'COMMON.SBRIDGE'
 268       include 'COMMON.DISTFIT'
 269       include 'COMMON.MD'
 270       double precision time
 271 #if defined(AIX) || defined(PGI)
 272       open(icart,file=cartname,position="append")
 273 #else
 274       open(icart,file=cartname,access="append")
 275 #endif
 276       write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath
 277       write (icart,'(i4,$)')
 278      &   nss,(ihpb(j),jhpb(j),j=1,nss)
 279        write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back,
 280      & (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair),
 281      & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
 282       write (icart,'(8f10.5)')
 283      & ((c(k,j),k=1,3),j=1,nres),
 284      & ((c(k,j+nres),k=1,3),j=nnt,nct)
 285       close(icart)
 286       return
 287       end
 288 c-----------------------------------------------------------------
 289 #ifndef NOXDR
 290       subroutine cartout(time)
 291       implicit real*8 (a-h,o-z)
 292       include 'DIMENSIONS'
 293 #ifdef MPI
 294       include 'mpif.h'
 295       include 'COMMON.SETUP'
 296 #else
 297       parameter (me=0)
 298 #endif
 299       include 'COMMON.CHAIN'
 300       include 'COMMON.INTERACT'
 301       include 'COMMON.NAMES'
 302       include 'COMMON.IOUNITS'
 303       include 'COMMON.HEADER'
 304       include 'COMMON.SBRIDGE'
 305       include 'COMMON.DISTFIT'
 306       include 'COMMON.MD'
 307       double precision time
 308       integer iret,itmp
 309       real xcoord(3,maxres2+2),prec
 310
 311 #ifdef AIX
 312       call xdrfopen_(ixdrf,cartname, "a", iret)
 313       call xdrffloat_(ixdrf, real(time), iret)
 314       call xdrffloat_(ixdrf, real(potE), iret)
 315       call xdrffloat_(ixdrf, real(uconst), iret)
 316       call xdrffloat_(ixdrf, real(uconst_back), iret)
 317       call xdrffloat_(ixdrf, real(t_bath), iret)
 318       call xdrfint_(ixdrf, nss, iret)
 319       do j=1,nss
 320         call xdrfint_(ixdrf, ihpb(j), iret)
 321         call xdrfint_(ixdrf, jhpb(j), iret)
 322       enddo
 323       call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret)
 324       do i=1,nfrag
 325         call xdrffloat_(ixdrf, real(qfrag(i)), iret)
 326       enddo
 327       do i=1,npair
 328         call xdrffloat_(ixdrf, real(qpair(i)), iret)
 329       enddo
 330       do i=1,nfrag_back
 331         call xdrffloat_(ixdrf, real(utheta(i)), iret)
 332         call xdrffloat_(ixdrf, real(ugamma(i)), iret)
 333         call xdrffloat_(ixdrf, real(uscdiff(i)), iret)
 334       enddo
 335 #else
 336       call xdrfopen(ixdrf,cartname, "a", iret)
 337       call xdrffloat(ixdrf, real(time), iret)
 338       call xdrffloat(ixdrf, real(potE), iret)
 339       call xdrffloat(ixdrf, real(uconst), iret)
 340       call xdrffloat(ixdrf, real(uconst_back), iret)
 341       call xdrffloat(ixdrf, real(t_bath), iret)
 342       call xdrfint(ixdrf, nss, iret)
 343       do j=1,nss
 344         call xdrfint(ixdrf, ihpb(j), iret)
 345         call xdrfint(ixdrf, jhpb(j), iret)
 346       enddo
 347       call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret)
 348       do i=1,nfrag
 349         call xdrffloat(ixdrf, real(qfrag(i)), iret)
 350       enddo
 351       do i=1,npair
 352         call xdrffloat(ixdrf, real(qpair(i)), iret)
 353       enddo
 354       do i=1,nfrag_back
 355         call xdrffloat(ixdrf, real(utheta(i)), iret)
 356         call xdrffloat(ixdrf, real(ugamma(i)), iret)
 357         call xdrffloat(ixdrf, real(uscdiff(i)), iret)
 358       enddo
 359 #endif
 360       prec=10000.0
 361       do i=1,nres
 362        do j=1,3
 363         xcoord(j,i)=c(j,i)
 364        enddo
 365       enddo
 366       do i=nnt,nct
 367        do j=1,3
 368         xcoord(j,nres+i-nnt+1)=c(j,i+nres)
 369        enddo
 370       enddo
 371
 372       itmp=nres+nct-nnt+1
 373 #ifdef AIX
 374       call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret)
 375       call xdrfclose_(ixdrf, iret)
 376 #else
 377       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
 378       call xdrfclose(ixdrf, iret)
 379 #endif
 380       return
 381       end
 382 c-----------------------------------------------
 383       subroutine read_cx(ixdrf,*)
 384 c     xdrfopen should be called before this subroutine
 385       implicit real*8 (a-h,o-z)
 386       include 'DIMENSIONS'
 387 #ifdef MPI
 388       include 'mpif.h'
 389       include 'COMMON.SETUP'
 390 #else
 391       parameter (me=0)
 392 #endif
 393       include 'COMMON.CHAIN'
 394       include 'COMMON.INTERACT'
 395       include 'COMMON.NAMES'
 396       include 'COMMON.IOUNITS'
 397       include 'COMMON.HEADER'
 398       include 'COMMON.SBRIDGE'
 399       include 'COMMON.DISTFIT'
 400       include 'COMMON.MD'
 401       include 'COMMON.LOCAL'
 402       double precision time
 403       integer iret,itmp
 404       real xcoord(3,maxres2+2),prec
 405       real r_time,r_potE,r_uconst,r_uconst_back,r_t_bath
 406
 407
 408 #ifdef AIX
 409 c      call xdrfopen_(ixdrf,cartname, "r", iret)
 410       call xdrffloat_(ixdrf, r_time, iret)
 411       if(iret.eq.0) return1
 412
 413       call xdrffloat_(ixdrf, r_potE), iret)
 414       call xdrffloat_(ixdrf, r_uconst), iret)
 415       call xdrffloat_(ixdrf, r_uconst_back), iret)
 416       call xdrffloat_(ixdrf, r_t_bath), iret)
 417       call xdrfint_(ixdrf, nss, iret)
 418       do j=1,nss
 419         call xdrfint_(ixdrf, ihpb(j), iret)
 420         call xdrfint_(ixdrf, jhpb(j), iret)
 421       enddo
 422       call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret)
 423       do i=1,nfrag
 424         call xdrffloat_(ixdrf, real(qfrag(i)), iret)
 425       enddo
 426       do i=1,npair
 427         call xdrffloat_(ixdrf, real(qpair(i)), iret)
 428       enddo
 429       do i=1,nfrag_back
 430         call xdrffloat_(ixdrf, real(utheta(i)), iret)
 431         call xdrffloat_(ixdrf, real(ugamma(i)), iret)
 432         call xdrffloat_(ixdrf, real(uscdiff(i)), iret)
 433       enddo
 434 #else
 435 c      call xdrfopen(ixdrf,cartname, "r", iret)
 436       call xdrffloat(ixdrf, r_time, iret)
 437       if(iret.eq.0) return1
 438
 439       call xdrffloat(ixdrf, r_potE, iret)
 440       call xdrffloat(ixdrf, r_uconst, iret)
 441       call xdrffloat(ixdrf, r_uconst_back, iret)
 442       call xdrffloat(ixdrf, r_t_bath, iret)
 443       call xdrfint(ixdrf, nss, iret)
 444       do j=1,nss
 445         call xdrfint(ixdrf, ihpb(j), iret)
 446         call xdrfint(ixdrf, jhpb(j), iret)
 447       enddo
 448       call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret)
 449       do i=1,nfrag
 450         call xdrffloat(ixdrf, real(qfrag(i)), iret)
 451       enddo
 452       do i=1,npair
 453         call xdrffloat(ixdrf, real(qpair(i)), iret)
 454       enddo
 455       do i=1,nfrag_back
 456         call xdrffloat(ixdrf, real(utheta(i)), iret)
 457         call xdrffloat(ixdrf, real(ugamma(i)), iret)
 458         call xdrffloat(ixdrf, real(uscdiff(i)), iret)
 459       enddo
 460 #endif
 461       prec=10000.0
 462
 463       itmp=nres+nct-nnt+1
 464 #ifdef AIX
 465       call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret)
 466 c      call xdrfclose_(ixdrf, iret)
 467 #else
 468       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
 469 c      call xdrfclose(ixdrf, iret)
 470 #endif
 471
 472       do i=1,nres
 473        do j=1,3
 474         c(j,i)=xcoord(j,i)
 475        enddo
 476       enddo
 477       do i=nnt,nct
 478        do j=1,3
 479         c(j,i+nres)=xcoord(j,nres+i-nnt+1)
 480        enddo
 481       enddo
 482
 483       call int_from_cart1(.false.)
 484
 485       do i=1,nres-1
 486         do j=1,3
 487           dc(j,i)=c(j,i+1)-c(j,i)
 488           dc_norm(j,i)=dc(j,i)*vbld_inv(i+1)
 489         enddo
 490       enddo
 491       do i=2,nres-1
 492         do j=1,3
 493           dc(j,i+nres)=c(j,i+nres)-c(j,i)
 494           dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres)
 495         enddo
 496       enddo
 497
 498       return
 499       end
 500 #endif
 501 c-----------------------------------------------------------------
 502       subroutine statout(itime)
 503       implicit real*8 (a-h,o-z)
 504       include 'DIMENSIONS'
 505       include 'COMMON.CONTROL'
 506       include 'COMMON.CHAIN'
 507       include 'COMMON.INTERACT'
 508       include 'COMMON.NAMES'
 509       include 'COMMON.IOUNITS'
 510       include 'COMMON.HEADER'
 511       include 'COMMON.SBRIDGE'
 512       include 'COMMON.DISTFIT'
 513       include 'COMMON.MD'
 514       include 'COMMON.REMD'
 515       include 'COMMON.SETUP'
 516       integer itime
 517       double precision energia(0:n_ene)
 518       double precision gyrate
 519       external gyrate
 520       common /gucio/ cm
 521       character*256 line1,line2
 522       character*4 format1,format2
 523       character*30 format
 524 #ifdef AIX
 525       if(itime.eq.0) then
 526        open(istat,file=statname,position="append")
 527       endif
 528 #else
 529 #ifdef PGI
 530       open(istat,file=statname,position="append")
 531 #else
 532       open(istat,file=statname,access="append")
 533 #endif
 534 #endif
 535        if (refstr) then
 536          call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
 537         if(tnp .or. tnp1 .or. tnh) then
 538         write (line1,'(i10,f15.2,3f12.3,f12.6,f7.2,4f6.3,3f12.3,i5,$)')
 539      &          itime,totT,EK,potE,totE,hhh,
 540      &          rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
 541           format1="a145"
 542         else
 543           write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)')
 544      &          itime,totT,EK,potE,totE,
 545      &          rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
 546           format1="a133"
 547         endif
 548        else
 549         if(tnp .or. tnp1 .or. tnh) then
 550           write (line1,'(i10,f15.2,7f12.3,f12.6,i5,$)')
 551      &           itime,totT,EK,potE,totE,hhh,
 552      &           amax,kinetic_T,t_bath,gyrate(),me
 553           format1="a126"
 554         else
 555           write (line1,'(i10,f15.2,7f12.3,i5,$)')
 556      &           itime,totT,EK,potE,totE,
 557      &           amax,kinetic_T,t_bath,gyrate(),me
 558           format1="a114"
 559         endif
 560        endif
 561         if(usampl.and.totT.gt.eq_time) then
 562            write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,
 563      &      (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),
 564      &      (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
 565            write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair
 566      &             +21*nfrag_back
 567         elseif(hremd.gt.0) then
 568            write(line2,'(i5)') iset
 569            format2="a005"
 570         else
 571            format2="a001"
 572            line2=' '
 573         endif
 574         if (print_compon) then
 575           if(itime.eq.0) then
 576            write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
 577      &                                                     ",20a12)"
 578            write (istat,format) "#","",
 579      &      (ename(print_order(i)),i=1,nprint_ene)
 580           endif
 581           write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
 582      &                                                     ",20f12.3)"
 583           write (istat,format) line1,line2,
 584      &      (potEcomp(print_order(i)),i=1,nprint_ene)
 585         else
 586           write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")"
 587           write (istat,format) line1,line2
 588         endif
 589 #if defined(AIX)
 590         call flush(istat)
 591 #else
 592         close(istat)
 593 #endif
 594        return
 595       end
 596 c---------------------------------------------------------------
 597       double precision function gyrate()
 598       implicit real*8 (a-h,o-z)
 599       include 'DIMENSIONS'
 600       include 'COMMON.INTERACT'
 601       include 'COMMON.CHAIN'
 602       double precision cen(3),rg
 603
 604       do j=1,3
 605        cen(j)=0.0d0
 606       enddo
 607
 608       do i=nnt,nct
 609           do j=1,3
 610             cen(j)=cen(j)+c(j,i)
 611           enddo
 612       enddo
 613       do j=1,3
 614             cen(j)=cen(j)/dble(nct-nnt+1)
 615       enddo
 616       rg = 0.0d0
 617       do i = nnt, nct
 618         do j=1,3
 619          rg = rg + (c(j,i)-cen(j))**2
 620         enddo
 621       end do
 622       gyrate = sqrt(rg/dble(nct-nnt+1))
 623       return
 624       end
 625