source/unres/src-HCD-5D/geomout.F

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