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(iss(idssb(i)))+1,ica(iss(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',8I5)
 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.CONTROL'
 339       include 'COMMON.CHAIN'
 340       include 'COMMON.INTERACT'
 341       include 'COMMON.NAMES'
 342       include 'COMMON.IOUNITS'
 343       include 'COMMON.HEADER'
 344       include 'COMMON.SBRIDGE'
 345       include 'COMMON.FRAG'
 346       include 'COMMON.MD'
 347       include 'COMMON.QRESTR'
 348       double precision time
 349       integer iret,itmp
 350       real xcoord(3,maxres2+2),prec
 351       integer i,j,ixdrf
 352
 353 #ifdef AIX
 354       call xdrfopen_(ixdrf,cartname, "a", iret)
 355       call xdrffloat_(ixdrf, real(time), iret)
 356       call xdrffloat_(ixdrf, real(potE), iret)
 357       call xdrffloat_(ixdrf, real(uconst), iret)
 358       call xdrffloat_(ixdrf, real(uconst_back), iret)
 359       call xdrffloat_(ixdrf, real(t_bath), iret)
 360       call xdrfint_(ixdrf, nss, iret)
 361       do j=1,nss
 362        if (dyn_ss) then
 363         if (modecalc.eq.14) then
 364           call xdrfint_(ixdrf, idssb(j), iret)
 365           call xdrfint_(ixdrf, jdssb(j), iret)
 366         else
 367           call xdrfint_(ixdrf, iss(idssb(j))+nres, iret)
 368           call xdrfint_(ixdrf, iss(jdssb(j))+nres, iret)
 369         endif
 370        else
 371         call xdrfint_(ixdrf, ihpb(j), iret)
 372         call xdrfint_(ixdrf, jhpb(j), iret)
 373        endif
 374       enddo
 375       call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret)
 376       do i=1,nfrag
 377         call xdrffloat_(ixdrf, real(qfrag(i)), iret)
 378       enddo
 379       do i=1,npair
 380         call xdrffloat_(ixdrf, real(qpair(i)), iret)
 381       enddo
 382       do i=1,nfrag_back
 383         call xdrffloat_(ixdrf, real(utheta(i)), iret)
 384         call xdrffloat_(ixdrf, real(ugamma(i)), iret)
 385         call xdrffloat_(ixdrf, real(uscdiff(i)), iret)
 386       enddo
 387 #else
 388       call xdrfopen(ixdrf,cartname, "a", iret)
 389 c      write (iout,*) "Writing conformation: time",time," potE",potE,
 390 c     & " uconst",uconst," uconst_back",uconst_back," t_bath",t_bath,
 391 c     & " nss",nss
 392       call xdrffloat(ixdrf, real(time), iret)
 393       call xdrffloat(ixdrf, real(potE), iret)
 394       call xdrffloat(ixdrf, real(uconst), iret)
 395       call xdrffloat(ixdrf, real(uconst_back), iret)
 396       call xdrffloat(ixdrf, real(t_bath), iret)
 397       call xdrfint(ixdrf, nss, iret)
 398       do j=1,nss
 399        if (dyn_ss) then
 400         if (modecalc.eq.14) then
 401           call xdrfint(ixdrf, idssb(j), iret)
 402           call xdrfint(ixdrf, jdssb(j), iret)
 403         else
 404           call xdrfint(ixdrf, iss(idssb(j))+nres, iret)
 405           call xdrfint(ixdrf, iss(jdssb(j))+nres, iret)
 406         endif
 407        else
 408         call xdrfint(ixdrf, ihpb(j), iret)
 409         call xdrfint(ixdrf, jhpb(j), iret)
 410        endif
 411       enddo
 412       call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret)
 413       do i=1,nfrag
 414         call xdrffloat(ixdrf, real(qfrag(i)), iret)
 415       enddo
 416       do i=1,npair
 417         call xdrffloat(ixdrf, real(qpair(i)), iret)
 418       enddo
 419       do i=1,nfrag_back
 420         call xdrffloat(ixdrf, real(utheta(i)), iret)
 421         call xdrffloat(ixdrf, real(ugamma(i)), iret)
 422         call xdrffloat(ixdrf, real(uscdiff(i)), iret)
 423       enddo
 424 #endif
 425       prec=10000.0
 426       do i=1,nres
 427        do j=1,3
 428         xcoord(j,i)=c(j,i)
 429        enddo
 430       enddo
 431       do i=nnt,nct
 432        do j=1,3
 433         xcoord(j,nres+i-nnt+1)=c(j,i+nres)
 434        enddo
 435       enddo
 436
 437       itmp=nres+nct-nnt+1
 438 #ifdef AIX
 439       call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret)
 440       call xdrfclose_(ixdrf, iret)
 441 #else
 442       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
 443       call xdrfclose(ixdrf, iret)
 444 #endif
 445       return
 446       end
 447 #endif
 448 c-----------------------------------------------------------------
 449       subroutine statout(itime)
 450       implicit real*8 (a-h,o-z)
 451       include 'DIMENSIONS'
 452       include 'COMMON.CONTROL'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.INTERACT'
 455       include 'COMMON.NAMES'
 456       include 'COMMON.IOUNITS'
 457       include 'COMMON.HEADER'
 458       include 'COMMON.SBRIDGE'
 459       include 'COMMON.FRAG'
 460       include 'COMMON.MD'
 461       include 'COMMON.QRESTR'
 462       include 'COMMON.REMD'
 463       include 'COMMON.SETUP'
 464       integer itime
 465       double precision energia(0:n_ene)
 466       double precision gyrate
 467       external gyrate
 468       common /gucio/ cm
 469       character*256 line1,line2
 470       character*4 format1,format2
 471       character*30 format
 472 #ifdef AIX
 473       if(itime.eq.0) then
 474        open(istat,file=statname,position="append")
 475       endif
 476 #else
 477 #if defined(PGI) || defined(CRAY)
 478       open(istat,file=statname,position="append")
 479 #else
 480       open(istat,file=statname,access="append")
 481 #endif
 482 #endif
 483        if (AFMlog.gt.0) then
 484        if (refstr) then
 485          call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
 486           write (line1,'(i10,f15.2,3f12.3,f7.2,2f6.3,4f12.3,i5,$)')
 487      &          itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27),
 488      &          rms,frac,frac_nn,kinetic_T,t_bath,gyrate(),
 489      &          potEcomp(23),me
 490           format1="a133"
 491          else
 492 C          print *,'A CHUJ',potEcomp(23)
 493           write (line1,'(i10,f15.2,7f12.3,i5,$)')
 494      &           itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27),
 495      &           kinetic_T,t_bath,gyrate(),
 496      &           potEcomp(23),me
 497           format1="a114"
 498         endif
 499        else if (selfguide.gt.0) then
 500        distance=0.0
 501        do j=1,3
 502        distance=distance+(c(j,afmend)-c(j,afmbeg))**2
 503        enddo
 504        distance=dsqrt(distance)
 505        if (refstr) then
 506          call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
 507           write (line1,'(i10,f15.2,3f12.3,f7.2,2f6.3,f12.3,f10.1,2f8.2,
 508      &    f9.3,i5,$)')
 509      &          itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27),
 510      &          rms,frac,frac_nn,kinetic_T,t_bath,gyrate(),
 511      &          distance,potEcomp(23),me
 512           format1="a133"
 513 C          print *,"CHUJOWO"
 514          else
 515 C          print *,'A CHUJ',potEcomp(23)
 516           write (line1,'(i10,f15.2,8f12.3,i5,$)')
 517      &           itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27),
 518      &           kinetic_T,t_bath,gyrate(),
 519      &           distance,potEcomp(23),me
 520           format1="a114"
 521         endif
 522        else
 523        if (refstr) then
 524          call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
 525           write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)')
 526      &          itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27),
 527      &          rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
 528           format1="a133"
 529         else
 530           write (line1,'(i10,f15.2,7f12.3,i5,$)')
 531      &           itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27),
 532      &           amax,kinetic_T,t_bath,gyrate(),me
 533           format1="a114"
 534         endif
 535         endif
 536         if(usampl.and.totT.gt.eq_time) then
 537            if (loc_qlike) then
 538            write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,
 539      &      (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),
 540      &      (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back),
 541      &      ((qloc(j,i),j=1,3),i=1,nfrag_back)
 542            write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair
 543      &             +42*nfrag_back
 544            else
 545            write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,
 546      &      (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),
 547      &      (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
 548            write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair
 549      &             +21*nfrag_back
 550            endif
 551         else
 552            format2="a001"
 553            line2=' '
 554         endif
 555         if (print_compon) then
 556           if(itime.eq.0) then
 557            write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
 558      &                                                     ",31a12)"
 559            write (istat,format) "#"," ",
 560      &      (ename(print_order(i)),i=1,nprint_ene)
 561           endif
 562           write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
 563      &                                                     ",31f12.3)"
 564           write (istat,format) line1,line2,
 565      &      (potEcomp(print_order(i)),i=1,nprint_ene)
 566         else
 567           write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")"
 568           write (istat,format) line1,line2
 569         endif
 570 #if defined(AIX)
 571         call flush(istat)
 572 #else
 573         close(istat)
 574 #endif
 575        return
 576       end
 577 c---------------------------------------------------------------
 578       double precision function gyrate()
 579       implicit none
 580       include 'DIMENSIONS'
 581       include 'COMMON.INTERACT'
 582       include 'COMMON.CHAIN'
 583       integer i,ii,j
 584       double precision cen(3),rg
 585
 586       do j=1,3
 587        cen(j)=0.0d0
 588       enddo
 589
 590       ii=0
 591       do i=nnt,nct
 592         if (itype(i).eq.ntyp1) cycle
 593         ii=ii+1
 594         do j=1,3
 595           cen(j)=cen(j)+c(j,i)
 596         enddo
 597       enddo
 598       do j=1,3
 599         cen(j)=cen(j)/dble(ii)
 600       enddo
 601       rg = 0.0d0
 602       do i = nnt, nct
 603         if (itype(i).eq.ntyp1) cycle
 604         do j=1,3
 605          rg = rg + (c(j,i)-cen(j))**2
 606         enddo
 607       end do
 608       gyrate = dsqrt(rg/dble(ii))
 609       return
 610       end