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