source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202       call esc(escloc)
 203 c      print *,"Processor",myrank," computed USC"
 204 C
 205 C Calculate the virtual-bond torsional energy.
 206 C
 207 cd    print *,'nterm=',nterm
 208       if (wtor.gt.0) then
 209        call etor(etors,edihcnstr)
 210       else
 211        etors=0
 212        edihcnstr=0
 213       endif
 214 c      print *,"Processor",myrank," computed Utor"
 215 C
 216 C 6/23/01 Calculate double-torsional energy
 217 C
 218       if (wtor_d.gt.0) then
 219        call etor_d(etors_d)
 220       else
 221        etors_d=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utord"
 224 C
 225 C 21/5/07 Calculate local sicdechain correlation energy
 226 C
 227       if (wsccor.gt.0.0d0) then
 228         call eback_sc_corr(esccor)
 229       else
 230         esccor=0.0d0
 231       endif
 232 c      print *,"Processor",myrank," computed Usccorr"
 233 C
 234 C 12/1/95 Multi-body terms
 235 C
 236       n_corr=0
 237       n_corr1=0
 238       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 239      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 240          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 241 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 242 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 243       else
 244          ecorr=0.0d0
 245          ecorr5=0.0d0
 246          ecorr6=0.0d0
 247          eturn6=0.0d0
 248       endif
 249       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 250          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 251 cd         write (iout,*) "multibody_hb ecorr",ecorr
 252       endif
 253 c      print *,"Processor",myrank," computed Ucorr"
 254 C
 255 C If performing constraint dynamics, call the constraint energy
 256 C  after the equilibration time
 257       if(usampl.and.totT.gt.eq_time) then
 258          call EconstrQ
 259          call Econstr_back
 260       else
 261          Uconst=0.0d0
 262          Uconst_back=0.0d0
 263       endif
 264 #ifdef TIMING
 265       time_enecalc=time_enecalc+MPI_Wtime()-time00
 266 #endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 #ifdef TIMING
 269       time00=MPI_Wtime()
 270 #endif
 271 c
 272 C Sum the energies
 273 C
 274       energia(1)=evdw
 275 #ifdef SCP14
 276       energia(2)=evdw2-evdw2_14
 277       energia(18)=evdw2_14
 278 #else
 279       energia(2)=evdw2
 280       energia(18)=0.0d0
 281 #endif
 282 #ifdef SPLITELE
 283       energia(3)=ees
 284       energia(16)=evdw1
 285 #else
 286       energia(3)=ees+evdw1
 287       energia(16)=0.0d0
 288 #endif
 289       energia(4)=ecorr
 290       energia(5)=ecorr5
 291       energia(6)=ecorr6
 292       energia(7)=eel_loc
 293       energia(8)=eello_turn3
 294       energia(9)=eello_turn4
 295       energia(10)=eturn6
 296       energia(11)=ebe
 297       energia(12)=escloc
 298       energia(13)=etors
 299       energia(14)=etors_d
 300       energia(15)=ehpb
 301       energia(19)=edihcnstr
 302       energia(17)=estr
 303       energia(20)=Uconst+Uconst_back
 304       energia(21)=esccor
 305 c    Here are the energies showed per procesor if the are more processors
 306 c    per molecule then we sum it up in sum_energy subroutine
 307 c      print *," Processor",myrank," calls SUM_ENERGY"
 308       call sum_energy(energia,.true.)
 309       if (dyn_ss) call dyn_set_nss
 310 c      print *," Processor",myrank," left SUM_ENERGY"
 311 #ifdef TIMING
 312       time_sumene=time_sumene+MPI_Wtime()-time00
 313 #endif
 314       return
 315       end
 316 c-------------------------------------------------------------------------------
 317       subroutine sum_energy(energia,reduce)
 318       implicit real*8 (a-h,o-z)
 319       include 'DIMENSIONS'
 320 #ifndef ISNAN
 321       external proc_proc
 322 #ifdef WINPGI
 323 cMS$ATTRIBUTES C ::  proc_proc
 324 #endif
 325 #endif
 326 #ifdef MPI
 327       include "mpif.h"
 328 #endif
 329       include 'COMMON.SETUP'
 330       include 'COMMON.IOUNITS'
 331       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 332       include 'COMMON.FFIELD'
 333       include 'COMMON.DERIV'
 334       include 'COMMON.INTERACT'
 335       include 'COMMON.SBRIDGE'
 336       include 'COMMON.CHAIN'
 337       include 'COMMON.VAR'
 338       include 'COMMON.CONTROL'
 339       include 'COMMON.TIME1'
 340       logical reduce
 341 #ifdef MPI
 342       if (nfgtasks.gt.1 .and. reduce) then
 343 #ifdef DEBUG
 344         write (iout,*) "energies before REDUCE"
 345         call enerprint(energia)
 346         call flush(iout)
 347 #endif
 348         do i=0,n_ene
 349           enebuff(i)=energia(i)
 350         enddo
 351         time00=MPI_Wtime()
 352         call MPI_Barrier(FG_COMM,IERR)
 353         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 354         time00=MPI_Wtime()
 355         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 356      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 357 #ifdef DEBUG
 358         write (iout,*) "energies after REDUCE"
 359         call enerprint(energia)
 360         call flush(iout)
 361 #endif
 362         time_Reduce=time_Reduce+MPI_Wtime()-time00
 363       endif
 364       if (fg_rank.eq.0) then
 365 #endif
 366       evdw=energia(1)
 367 #ifdef SCP14
 368       evdw2=energia(2)+energia(18)
 369       evdw2_14=energia(18)
 370 #else
 371       evdw2=energia(2)
 372 #endif
 373 #ifdef SPLITELE
 374       ees=energia(3)
 375       evdw1=energia(16)
 376 #else
 377       ees=energia(3)
 378       evdw1=0.0d0
 379 #endif
 380       ecorr=energia(4)
 381       ecorr5=energia(5)
 382       ecorr6=energia(6)
 383       eel_loc=energia(7)
 384       eello_turn3=energia(8)
 385       eello_turn4=energia(9)
 386       eturn6=energia(10)
 387       ebe=energia(11)
 388       escloc=energia(12)
 389       etors=energia(13)
 390       etors_d=energia(14)
 391       ehpb=energia(15)
 392       edihcnstr=energia(19)
 393       estr=energia(17)
 394       Uconst=energia(20)
 395       esccor=energia(21)
 396 #ifdef SPLITELE
 397       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #else
 404       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 405      & +wang*ebe+wtor*etors+wscloc*escloc
 406      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 407      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 408      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 409      & +wbond*estr+Uconst+wsccor*esccor
 410 #endif
 411       energia(0)=etot
 412 c detecting NaNQ
 413 #ifdef ISNAN
 414 #ifdef AIX
 415       if (isnan(etot).ne.0) energia(0)=1.0d+99
 416 #else
 417       if (isnan(etot)) energia(0)=1.0d+99
 418 #endif
 419 #else
 420       i=0
 421 #ifdef WINPGI
 422       idumm=proc_proc(etot,i)
 423 #else
 424       call proc_proc(etot,i)
 425 #endif
 426       if(i.eq.1)energia(0)=1.0d+99
 427 #endif
 428 #ifdef MPI
 429       endif
 430 #endif
 431       return
 432       end
 433 c-------------------------------------------------------------------------------
 434       subroutine sum_gradient
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437 #ifndef ISNAN
 438       external proc_proc
 439 #ifdef WINPGI
 440 cMS$ATTRIBUTES C ::  proc_proc
 441 #endif
 442 #endif
 443 #ifdef MPI
 444       include 'mpif.h'
 445 #endif
 446       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 447      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 448       include 'COMMON.SETUP'
 449       include 'COMMON.IOUNITS'
 450       include 'COMMON.FFIELD'
 451       include 'COMMON.DERIV'
 452       include 'COMMON.INTERACT'
 453       include 'COMMON.SBRIDGE'
 454       include 'COMMON.CHAIN'
 455       include 'COMMON.VAR'
 456       include 'COMMON.CONTROL'
 457       include 'COMMON.TIME1'
 458       include 'COMMON.MAXGRAD'
 459       include 'COMMON.SCCOR'
 460 #ifdef TIMING
 461       time01=MPI_Wtime()
 462 #endif
 463 #ifdef DEBUG
 464       write (iout,*) "sum_gradient gvdwc, gvdwx"
 465       do i=1,nres
 466         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 467      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 468       enddo
 469       call flush(iout)
 470 #endif
 471 #ifdef MPI
 472 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 473         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 474      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 475 #endif
 476 C
 477 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 478 C            in virtual-bond-vector coordinates
 479 C
 480 #ifdef DEBUG
 481 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 482 c      do i=1,nres-1
 483 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 484 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 485 c      enddo
 486 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 489 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 490 c      enddo
 491       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 492       do i=1,nres
 493         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 494      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 495      &   g_corr5_loc(i)
 496       enddo
 497       call flush(iout)
 498 #endif
 499 #ifdef SPLITELE
 500       do i=1,nct
 501         do j=1,3
 502           gradbufc(j,i)=wsc*gvdwc(j,i)+
 503      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 504      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 505      &                wel_loc*gel_loc_long(j,i)+
 506      &                wcorr*gradcorr_long(j,i)+
 507      &                wcorr5*gradcorr5_long(j,i)+
 508      &                wcorr6*gradcorr6_long(j,i)+
 509      &                wturn6*gcorr6_turn_long(j,i)+
 510      &                wstrain*ghpbc(j,i)
 511         enddo
 512       enddo
 513 #else
 514       do i=1,nct
 515         do j=1,3
 516           gradbufc(j,i)=wsc*gvdwc(j,i)+
 517      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 518      &                welec*gelc_long(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526         enddo
 527       enddo
 528 #endif
 529 #ifdef MPI
 530       if (nfgtasks.gt.1) then
 531       time00=MPI_Wtime()
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc before allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539       do i=1,nres
 540         do j=1,3
 541           gradbufc_sum(j,i)=gradbufc(j,i)
 542         enddo
 543       enddo
 544 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 545 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 546 c      time_reduce=time_reduce+MPI_Wtime()-time00
 547 #ifdef DEBUG
 548 c      write (iout,*) "gradbufc_sum after allreduce"
 549 c      do i=1,nres
 550 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 551 c      enddo
 552 c      call flush(iout)
 553 #endif
 554 #ifdef TIMING
 555 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 556 #endif
 557       do i=nnt,nres
 558         do k=1,3
 559           gradbufc(k,i)=0.0d0
 560         enddo
 561       enddo
 562 #ifdef DEBUG
 563       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 564       write (iout,*) (i," jgrad_start",jgrad_start(i),
 565      &                  " jgrad_end  ",jgrad_end(i),
 566      &                  i=igrad_start,igrad_end)
 567 #endif
 568 c
 569 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 570 c do not parallelize this part.
 571 c
 572 c      do i=igrad_start,igrad_end
 573 c        do j=jgrad_start(i),jgrad_end(i)
 574 c          do k=1,3
 575 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 576 c          enddo
 577 c        enddo
 578 c      enddo
 579       do j=1,3
 580         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 581       enddo
 582       do i=nres-2,nnt,-1
 583         do j=1,3
 584           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 585         enddo
 586       enddo
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc after summing"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       else
 595 #endif
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       do i=1,nres
 604         do j=1,3
 605           gradbufc_sum(j,i)=gradbufc(j,i)
 606           gradbufc(j,i)=0.0d0
 607         enddo
 608       enddo
 609       do j=1,3
 610         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 611       enddo
 612       do i=nres-2,nnt,-1
 613         do j=1,3
 614           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 615         enddo
 616       enddo
 617 c      do i=nnt,nres-1
 618 c        do k=1,3
 619 c          gradbufc(k,i)=0.0d0
 620 c        enddo
 621 c        do j=i+1,nres
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gradbufc after summing"
 629       do i=1,nres
 630         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635       endif
 636 #endif
 637       do k=1,3
 638         gradbufc(k,nres)=0.0d0
 639       enddo
 640       do i=1,nct
 641         do j=1,3
 642 #ifdef SPLITELE
 643           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 644      &                wel_loc*gel_loc(j,i)+
 645      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 646      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 647      &                wel_loc*gel_loc_long(j,i)+
 648      &                wcorr*gradcorr_long(j,i)+
 649      &                wcorr5*gradcorr5_long(j,i)+
 650      &                wcorr6*gradcorr6_long(j,i)+
 651      &                wturn6*gcorr6_turn_long(j,i))+
 652      &                wbond*gradb(j,i)+
 653      &                wcorr*gradcorr(j,i)+
 654      &                wturn3*gcorr3_turn(j,i)+
 655      &                wturn4*gcorr4_turn(j,i)+
 656      &                wcorr5*gradcorr5(j,i)+
 657      &                wcorr6*gradcorr6(j,i)+
 658      &                wturn6*gcorr6_turn(j,i)+
 659      &                wsccor*gsccorc(j,i)
 660      &               +wscloc*gscloc(j,i)
 661 #else
 662           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 663      &                wel_loc*gel_loc(j,i)+
 664      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 665      &                welec*gelc_long(j,i)
 666      &                wel_loc*gel_loc_long(j,i)+
 667      &                wcorr*gcorr_long(j,i)+
 668      &                wcorr5*gradcorr5_long(j,i)+
 669      &                wcorr6*gradcorr6_long(j,i)+
 670      &                wturn6*gcorr6_turn_long(j,i))+
 671      &                wbond*gradb(j,i)+
 672      &                wcorr*gradcorr(j,i)+
 673      &                wturn3*gcorr3_turn(j,i)+
 674      &                wturn4*gcorr4_turn(j,i)+
 675      &                wcorr5*gradcorr5(j,i)+
 676      &                wcorr6*gradcorr6(j,i)+
 677      &                wturn6*gcorr6_turn(j,i)+
 678      &                wsccor*gsccorc(j,i)
 679      &               +wscloc*gscloc(j,i)
 680 #endif
 681           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 682      &                  wbond*gradbx(j,i)+
 683      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 684      &                  wsccor*gsccorx(j,i)
 685      &                 +wscloc*gsclocx(j,i)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gloc before adding corr"
 690       do i=1,4*nres
 691         write (iout,*) i,gloc(i,icg)
 692       enddo
 693 #endif
 694       do i=1,nres-3
 695         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 696      &   +wcorr5*g_corr5_loc(i)
 697      &   +wcorr6*g_corr6_loc(i)
 698      &   +wturn4*gel_loc_turn4(i)
 699      &   +wturn3*gel_loc_turn3(i)
 700      &   +wturn6*gel_loc_turn6(i)
 701      &   +wel_loc*gel_loc_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720 c#define DEBUG
 721 #ifdef DEBUG
 722       write (iout,*) "gloc_sc before reduce"
 723       do i=1,nres
 724        do j=1,1
 725         write (iout,*) i,j,gloc_sc(j,i,icg)
 726        enddo
 727       enddo
 728 #endif
 729 c#undef DEBUG
 730         do i=1,nres
 731          do j=1,3
 732           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 733          enddo
 734         enddo
 735         time00=MPI_Wtime()
 736         call MPI_Barrier(FG_COMM,IERR)
 737         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 738         time00=MPI_Wtime()
 739         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 744      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 745         time_reduce=time_reduce+MPI_Wtime()-time00
 746         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         time_reduce=time_reduce+MPI_Wtime()-time00
 749 c#define DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc_sc after reduce"
 752       do i=1,nres
 753        do j=1,1
 754         write (iout,*) i,j,gloc_sc(j,i,icg)
 755        enddo
 756       enddo
 757 #endif
 758 c#undef DEBUG
 759 #ifdef DEBUG
 760       write (iout,*) "gloc after reduce"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       endif
 766 #endif
 767       if (gnorm_check) then
 768 c
 769 c Compute the maximum elements of the gradient
 770 c
 771       gvdwc_max=0.0d0
 772       gvdwc_scp_max=0.0d0
 773       gelc_max=0.0d0
 774       gvdwpp_max=0.0d0
 775       gradb_max=0.0d0
 776       ghpbc_max=0.0d0
 777       gradcorr_max=0.0d0
 778       gel_loc_max=0.0d0
 779       gcorr3_turn_max=0.0d0
 780       gcorr4_turn_max=0.0d0
 781       gradcorr5_max=0.0d0
 782       gradcorr6_max=0.0d0
 783       gcorr6_turn_max=0.0d0
 784       gsccorc_max=0.0d0
 785       gscloc_max=0.0d0
 786       gvdwx_max=0.0d0
 787       gradx_scp_max=0.0d0
 788       ghpbx_max=0.0d0
 789       gradxorr_max=0.0d0
 790       gsccorx_max=0.0d0
 791       gsclocx_max=0.0d0
 792       do i=1,nct
 793         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 794         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 795         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 796         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 797      &   gvdwc_scp_max=gvdwc_scp_norm
 798         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 799         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 800         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 801         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 802         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 803         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 804         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 805         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 806         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 807         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 808         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 809         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 810         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 811      &    gcorr3_turn(1,i)))
 812         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 813      &    gcorr3_turn_max=gcorr3_turn_norm
 814         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 815      &    gcorr4_turn(1,i)))
 816         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 817      &    gcorr4_turn_max=gcorr4_turn_norm
 818         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 819         if (gradcorr5_norm.gt.gradcorr5_max)
 820      &    gradcorr5_max=gradcorr5_norm
 821         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 822         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 823         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 824      &    gcorr6_turn(1,i)))
 825         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 826      &    gcorr6_turn_max=gcorr6_turn_norm
 827         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 828         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 829         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 830         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 831         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 832         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 833         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 834         if (gradx_scp_norm.gt.gradx_scp_max)
 835      &    gradx_scp_max=gradx_scp_norm
 836         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 837         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 838         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 839         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 840         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 841         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 842         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 843         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 844       enddo
 845       if (gradout) then
 846 #ifdef AIX
 847         open(istat,file=statname,position="append")
 848 #else
 849         open(istat,file=statname,access="append")
 850 #endif
 851         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 852      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 853      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 854      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 855      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 856      &     gsccorx_max,gsclocx_max
 857         close(istat)
 858         if (gvdwc_max.gt.1.0d4) then
 859           write (iout,*) "gvdwc gvdwx gradb gradbx"
 860           do i=nnt,nct
 861             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 862      &        gradb(j,i),gradbx(j,i),j=1,3)
 863           enddo
 864           call pdbout(0.0d0,'cipiszcze',iout)
 865           call flush(iout)
 866         endif
 867       endif
 868       endif
 869 #ifdef DEBUG
 870       write (iout,*) "gradc gradx gloc"
 871       do i=1,nres
 872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 873      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 874       enddo
 875 #endif
 876 #ifdef TIMING
 877       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 878 #endif
 879       return
 880       end
 881 c-------------------------------------------------------------------------------
 882       subroutine rescale_weights(t_bath)
 883       implicit real*8 (a-h,o-z)
 884       include 'DIMENSIONS'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.FFIELD'
 887       include 'COMMON.SBRIDGE'
 888       double precision kfac /2.4d0/
 889       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 890 c      facT=temp0/t_bath
 891 c      facT=2*temp0/(t_bath+temp0)
 892       if (rescale_mode.eq.0) then
 893         facT=1.0d0
 894         facT2=1.0d0
 895         facT3=1.0d0
 896         facT4=1.0d0
 897         facT5=1.0d0
 898       else if (rescale_mode.eq.1) then
 899         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 900         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 901         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 902         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 903         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 904       else if (rescale_mode.eq.2) then
 905         x=t_bath/temp0
 906         x2=x*x
 907         x3=x2*x
 908         x4=x3*x
 909         x5=x4*x
 910         facT=licznik/dlog(dexp(x)+dexp(-x))
 911         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 912         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 913         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 914         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 915       else
 916         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 917         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 918 #ifdef MPI
 919        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 920 #endif
 921        stop 555
 922       endif
 923       welec=weights(3)*fact
 924       wcorr=weights(4)*fact3
 925       wcorr5=weights(5)*fact4
 926       wcorr6=weights(6)*fact5
 927       wel_loc=weights(7)*fact2
 928       wturn3=weights(8)*fact2
 929       wturn4=weights(9)*fact3
 930       wturn6=weights(10)*fact5
 931       wtor=weights(13)*fact
 932       wtor_d=weights(14)*fact2
 933       wsccor=weights(21)*fact
 934
 935       return
 936       end
 937 C------------------------------------------------------------------------
 938       subroutine enerprint(energia)
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.FFIELD'
 943       include 'COMMON.SBRIDGE'
 944       include 'COMMON.MD'
 945       double precision energia(0:n_ene)
 946       etot=energia(0)
 947       evdw=energia(1)
 948       evdw2=energia(2)
 949 #ifdef SCP14
 950       evdw2=energia(2)+energia(18)
 951 #else
 952       evdw2=energia(2)
 953 #endif
 954       ees=energia(3)
 955 #ifdef SPLITELE
 956       evdw1=energia(16)
 957 #endif
 958       ecorr=energia(4)
 959       ecorr5=energia(5)
 960       ecorr6=energia(6)
 961       eel_loc=energia(7)
 962       eello_turn3=energia(8)
 963       eello_turn4=energia(9)
 964       eello_turn6=energia(10)
 965       ebe=energia(11)
 966       escloc=energia(12)
 967       etors=energia(13)
 968       etors_d=energia(14)
 969       ehpb=energia(15)
 970       edihcnstr=energia(19)
 971       estr=energia(17)
 972       Uconst=energia(20)
 973       esccor=energia(21)
 974 #ifdef SPLITELE
 975       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 976      &  estr,wbond,ebe,wang,
 977      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 978      &  ecorr,wcorr,
 979      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 980      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 981      &  edihcnstr,ebr*nss,
 982      &  Uconst,etot
 983    10 format (/'Virtual-chain energies:'//
 984      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 985      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 986      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 987      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 988      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 989      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 990      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 991      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 992      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 993      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 994      & ' (SS bridges & dist. cnstr.)'/
 995      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 999      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1000      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1001      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1002      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1003      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1004      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1005      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1006      & 'ETOT=  ',1pE16.6,' (total)')
1007 #else
1008       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1009      &  estr,wbond,ebe,wang,
1010      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1011      &  ecorr,wcorr,
1012      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1013      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1014      &  ebr*nss,Uconst,etot
1015    10 format (/'Virtual-chain energies:'//
1016      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1017      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1018      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1019      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1020      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1021      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1022      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1023      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1024      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1025      & ' (SS bridges & dist. cnstr.)'/
1026      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1030      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1031      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1032      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1033      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1034      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1035      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1036      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1037      & 'ETOT=  ',1pE16.6,' (total)')
1038 #endif
1039       return
1040       end
1041 C-----------------------------------------------------------------------
1042       subroutine elj(evdw)
1043 C
1044 C This subroutine calculates the interaction energy of nonbonded side chains
1045 C assuming the LJ potential of interaction.
1046 C
1047       implicit real*8 (a-h,o-z)
1048       include 'DIMENSIONS'
1049       parameter (accur=1.0d-10)
1050       include 'COMMON.GEO'
1051       include 'COMMON.VAR'
1052       include 'COMMON.LOCAL'
1053       include 'COMMON.CHAIN'
1054       include 'COMMON.DERIV'
1055       include 'COMMON.INTERACT'
1056       include 'COMMON.TORSION'
1057       include 'COMMON.SBRIDGE'
1058       include 'COMMON.NAMES'
1059       include 'COMMON.IOUNITS'
1060       include 'COMMON.CONTACTS'
1061       dimension gg(3)
1062 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1063       evdw=0.0D0
1064       do i=iatsc_s,iatsc_e
1065         itypi=iabs(itype(i))
1066         if (itypi.eq.ntyp1) cycle
1067         itypi1=iabs(itype(i+1))
1068         xi=c(1,nres+i)
1069         yi=c(2,nres+i)
1070         zi=c(3,nres+i)
1071 C Change 12/1/95
1072         num_conti=0
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1078 cd   &                  'iend=',iend(i,iint)
1079           do j=istart(i,iint),iend(i,iint)
1080             itypj=iabs(itype(j))
1081             if (itypj.eq.ntyp1) cycle
1082             xj=c(1,nres+j)-xi
1083             yj=c(2,nres+j)-yi
1084             zj=c(3,nres+j)-zi
1085 C Change 12/1/95 to calculate four-body interactions
1086             rij=xj*xj+yj*yj+zj*zj
1087             rrij=1.0D0/rij
1088 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1089             eps0ij=eps(itypi,itypj)
1090             fac=rrij**expon2
1091             e1=fac*fac*aa(itypi,itypj)
1092             e2=fac*bb(itypi,itypj)
1093             evdwij=e1+e2
1094 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1097 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1098 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1099 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1100             evdw=evdw+evdwij
1101 C
1102 C Calculate the components of the gradient in DC and X
1103 C
1104             fac=-rrij*(e1+evdwij)
1105             gg(1)=xj*fac
1106             gg(2)=yj*fac
1107             gg(3)=zj*fac
1108             do k=1,3
1109               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1110               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1111               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1112               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1113             enddo
1114 cgrad            do k=i,j-1
1115 cgrad              do l=1,3
1116 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1117 cgrad              enddo
1118 cgrad            enddo
1119 C
1120 C 12/1/95, revised on 5/20/97
1121 C
1122 C Calculate the contact function. The ith column of the array JCONT will
1123 C contain the numbers of atoms that make contacts with the atom I (of numbers
1124 C greater than I). The arrays FACONT and GACONT will contain the values of
1125 C the contact function and its derivative.
1126 C
1127 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1128 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1129 C Uncomment next line, if the correlation interactions are contact function only
1130             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1131               rij=dsqrt(rij)
1132               sigij=sigma(itypi,itypj)
1133               r0ij=rs0(itypi,itypj)
1134 C
1135 C Check whether the SC's are not too far to make a contact.
1136 C
1137               rcut=1.5d0*r0ij
1138               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1139 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1140 C
1141               if (fcont.gt.0.0D0) then
1142 C If the SC-SC distance if close to sigma, apply spline.
1143 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1144 cAdam &             fcont1,fprimcont1)
1145 cAdam           fcont1=1.0d0-fcont1
1146 cAdam           if (fcont1.gt.0.0d0) then
1147 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1148 cAdam             fcont=fcont*fcont1
1149 cAdam           endif
1150 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1151 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1152 cga             do k=1,3
1153 cga               gg(k)=gg(k)*eps0ij
1154 cga             enddo
1155 cga             eps0ij=-evdwij*eps0ij
1156 C Uncomment for AL's type of SC correlation interactions.
1157 cadam           eps0ij=-evdwij
1158                 num_conti=num_conti+1
1159                 jcont(num_conti,i)=j
1160                 facont(num_conti,i)=fcont*eps0ij
1161                 fprimcont=eps0ij*fprimcont/rij
1162                 fcont=expon*fcont
1163 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1164 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1165 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1166 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1167                 gacont(1,num_conti,i)=-fprimcont*xj
1168                 gacont(2,num_conti,i)=-fprimcont*yj
1169                 gacont(3,num_conti,i)=-fprimcont*zj
1170 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1171 cd              write (iout,'(2i3,3f10.5)')
1172 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1173               endif
1174             endif
1175           enddo      ! j
1176         enddo        ! iint
1177 C Change 12/1/95
1178         num_cont(i)=num_conti
1179       enddo          ! i
1180       do i=1,nct
1181         do j=1,3
1182           gvdwc(j,i)=expon*gvdwc(j,i)
1183           gvdwx(j,i)=expon*gvdwx(j,i)
1184         enddo
1185       enddo
1186 C******************************************************************************
1187 C
1188 C                              N O T E !!!
1189 C
1190 C To save time, the factor of EXPON has been extracted from ALL components
1191 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1192 C use!
1193 C
1194 C******************************************************************************
1195       return
1196       end
1197 C-----------------------------------------------------------------------------
1198       subroutine eljk(evdw)
1199 C
1200 C This subroutine calculates the interaction energy of nonbonded side chains
1201 C assuming the LJK potential of interaction.
1202 C
1203       implicit real*8 (a-h,o-z)
1204       include 'DIMENSIONS'
1205       include 'COMMON.GEO'
1206       include 'COMMON.VAR'
1207       include 'COMMON.LOCAL'
1208       include 'COMMON.CHAIN'
1209       include 'COMMON.DERIV'
1210       include 'COMMON.INTERACT'
1211       include 'COMMON.IOUNITS'
1212       include 'COMMON.NAMES'
1213       dimension gg(3)
1214       logical scheck
1215 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1216       evdw=0.0D0
1217       do i=iatsc_s,iatsc_e
1218         itypi=iabs(itype(i))
1219         if (itypi.eq.ntyp1) cycle
1220         itypi1=iabs(itype(i+1))
1221         xi=c(1,nres+i)
1222         yi=c(2,nres+i)
1223         zi=c(3,nres+i)
1224 C
1225 C Calculate SC interaction energy.
1226 C
1227         do iint=1,nint_gr(i)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             fac_augm=rrij**expon
1236             e_augm=augm(itypi,itypj)*fac_augm
1237             r_inv_ij=dsqrt(rrij)
1238             rij=1.0D0/r_inv_ij
1239             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1240             fac=r_shift_inv**expon
1241             e1=fac*fac*aa(itypi,itypj)
1242             e2=fac*bb(itypi,itypj)
1243             evdwij=e_augm+e1+e2
1244 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1245 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1246 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1247 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1248 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1249 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1250 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1251             evdw=evdw+evdwij
1252 C
1253 C Calculate the components of the gradient in DC and X
1254 C
1255             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1256             gg(1)=xj*fac
1257             gg(2)=yj*fac
1258             gg(3)=zj*fac
1259             do k=1,3
1260               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1261               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1262               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1263               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1264             enddo
1265 cgrad            do k=i,j-1
1266 cgrad              do l=1,3
1267 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1268 cgrad              enddo
1269 cgrad            enddo
1270           enddo      ! j
1271         enddo        ! iint
1272       enddo          ! i
1273       do i=1,nct
1274         do j=1,3
1275           gvdwc(j,i)=expon*gvdwc(j,i)
1276           gvdwx(j,i)=expon*gvdwx(j,i)
1277         enddo
1278       enddo
1279       return
1280       end
1281 C-----------------------------------------------------------------------------
1282       subroutine ebp(evdw)
1283 C
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the Berne-Pechukas potential of interaction.
1286 C
1287       implicit real*8 (a-h,o-z)
1288       include 'DIMENSIONS'
1289       include 'COMMON.GEO'
1290       include 'COMMON.VAR'
1291       include 'COMMON.LOCAL'
1292       include 'COMMON.CHAIN'
1293       include 'COMMON.DERIV'
1294       include 'COMMON.NAMES'
1295       include 'COMMON.INTERACT'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.CALC'
1298       common /srutu/ icall
1299 c     double precision rrsave(maxdim)
1300       logical lprn
1301       evdw=0.0D0
1302 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1303       evdw=0.0D0
1304 c     if (icall.eq.0) then
1305 c       lprn=.true.
1306 c     else
1307         lprn=.false.
1308 c     endif
1309       ind=0
1310       do i=iatsc_s,iatsc_e
1311         itypi=iabs(itype(i))
1312         if (itypi.eq.ntyp1) cycle
1313         itypi1=iabs(itype(i+1))
1314         xi=c(1,nres+i)
1315         yi=c(2,nres+i)
1316         zi=c(3,nres+i)
1317         dxi=dc_norm(1,nres+i)
1318         dyi=dc_norm(2,nres+i)
1319         dzi=dc_norm(3,nres+i)
1320 c        dsci_inv=dsc_inv(itypi)
1321         dsci_inv=vbld_inv(i+nres)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             ind=ind+1
1328             itypj=iabs(itype(j))
1329             if (itypj.eq.ntyp1) cycle
1330 c            dscj_inv=dsc_inv(itypj)
1331             dscj_inv=vbld_inv(j+nres)
1332             chi1=chi(itypi,itypj)
1333             chi2=chi(itypj,itypi)
1334             chi12=chi1*chi2
1335             chip1=chip(itypi)
1336             chip2=chip(itypj)
1337             chip12=chip1*chip2
1338             alf1=alp(itypi)
1339             alf2=alp(itypj)
1340             alf12=0.5D0*(alf1+alf2)
1341 C For diagnostics only!!!
1342 c           chi1=0.0D0
1343 c           chi2=0.0D0
1344 c           chi12=0.0D0
1345 c           chip1=0.0D0
1346 c           chip2=0.0D0
1347 c           chip12=0.0D0
1348 c           alf1=0.0D0
1349 c           alf2=0.0D0
1350 c           alf12=0.0D0
1351             xj=c(1,nres+j)-xi
1352             yj=c(2,nres+j)-yi
1353             zj=c(3,nres+j)-zi
1354             dxj=dc_norm(1,nres+j)
1355             dyj=dc_norm(2,nres+j)
1356             dzj=dc_norm(3,nres+j)
1357             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1358 cd          if (icall.eq.0) then
1359 cd            rrsave(ind)=rrij
1360 cd          else
1361 cd            rrij=rrsave(ind)
1362 cd          endif
1363             rij=dsqrt(rrij)
1364 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1365             call sc_angular
1366 C Calculate whole angle-dependent part of epsilon and contributions
1367 C to its derivatives
1368             fac=(rrij*sigsq)**expon2
1369             e1=fac*fac*aa(itypi,itypj)
1370             e2=fac*bb(itypi,itypj)
1371             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1372             eps2der=evdwij*eps3rt
1373             eps3der=evdwij*eps2rt
1374             evdwij=evdwij*eps2rt*eps3rt
1375             evdw=evdw+evdwij
1376             if (lprn) then
1377             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1378             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1379 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1380 cd     &        restyp(itypi),i,restyp(itypj),j,
1381 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1382 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1383 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1384 cd     &        evdwij
1385             endif
1386 C Calculate gradient components.
1387             e1=e1*eps1*eps2rt**2*eps3rt**2
1388             fac=-expon*(e1+evdwij)
1389             sigder=fac/sigsq
1390             fac=rrij*fac
1391 C Calculate radial part of the gradient
1392             gg(1)=xj*fac
1393             gg(2)=yj*fac
1394             gg(3)=zj*fac
1395 C Calculate the angular part of the gradient and sum add the contributions
1396 C to the appropriate components of the Cartesian gradient.
1397             call sc_grad
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401 c     stop
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine egb(evdw)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Gay-Berne potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       include 'COMMON.CONTROL'
1422       include 'COMMON.SPLITELE'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       integer xshift,yshift,zshift
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1434 C we have the original box)
1435 C      do xshift=-1,1
1436 C      do yshift=-1,1
1437 C      do zshift=-1,1
1438       do i=iatsc_s,iatsc_e
1439         itypi=iabs(itype(i))
1440         if (itypi.eq.ntyp1) cycle
1441         itypi1=iabs(itype(i+1))
1442         xi=c(1,nres+i)
1443         yi=c(2,nres+i)
1444         zi=c(3,nres+i)
1445 C Return atom into box, boxxsize is size of box in x dimension
1446 c  134   continue
1447 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1448 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1449 C Condition for being inside the proper box
1450 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1451 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1452 c        go to 134
1453 c        endif
1454 c  135   continue
1455 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1456 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1457 C Condition for being inside the proper box
1458 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1459 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1460 c        go to 135
1461 c        endif
1462 c  136   continue
1463 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1464 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1465 C Condition for being inside the proper box
1466 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1467 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1468 c        go to 136
1469 c        endif
1470           xi=mod(xi,boxxsize)
1471           if (xi.lt.0) xi=xi+boxxsize
1472           yi=mod(yi,boxysize)
1473           if (yi.lt.0) yi=yi+boxysize
1474           zi=mod(zi,boxzsize)
1475           if (zi.lt.0) zi=zi+boxzsize
1476 C          xi=xi+xshift*boxxsize
1477 C          yi=yi+yshift*boxysize
1478 C          zi=zi+zshift*boxzsize
1479
1480         dxi=dc_norm(1,nres+i)
1481         dyi=dc_norm(2,nres+i)
1482         dzi=dc_norm(3,nres+i)
1483 c        dsci_inv=dsc_inv(itypi)
1484         dsci_inv=vbld_inv(i+nres)
1485 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1486 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1487 C
1488 C Calculate SC interaction energy.
1489 C
1490         do iint=1,nint_gr(i)
1491           do j=istart(i,iint),iend(i,iint)
1492             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1493               call dyn_ssbond_ene(i,j,evdwij)
1494               evdw=evdw+evdwij
1495               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1496      &                        'evdw',i,j,evdwij,' ss'
1497             ELSE
1498             ind=ind+1
1499             itypj=iabs(itype(j))
1500             if (itypj.eq.ntyp1) cycle
1501 c            dscj_inv=dsc_inv(itypj)
1502             dscj_inv=vbld_inv(j+nres)
1503 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1504 c     &       1.0d0/vbld(j+nres)
1505 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1506             sig0ij=sigma(itypi,itypj)
1507             chi1=chi(itypi,itypj)
1508             chi2=chi(itypj,itypi)
1509             chi12=chi1*chi2
1510             chip1=chip(itypi)
1511             chip2=chip(itypj)
1512             chip12=chip1*chip2
1513             alf1=alp(itypi)
1514             alf2=alp(itypj)
1515             alf12=0.5D0*(alf1+alf2)
1516 C For diagnostics only!!!
1517 c           chi1=0.0D0
1518 c           chi2=0.0D0
1519 c           chi12=0.0D0
1520 c           chip1=0.0D0
1521 c           chip2=0.0D0
1522 c           chip12=0.0D0
1523 c           alf1=0.0D0
1524 c           alf2=0.0D0
1525 c           alf12=0.0D0
1526             xj=c(1,nres+j)
1527             yj=c(2,nres+j)
1528             zj=c(3,nres+j)
1529 C Return atom J into box the original box
1530 c  137   continue
1531 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1532 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1533 C Condition for being inside the proper box
1534 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1535 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1536 c        go to 137
1537 c        endif
1538 c  138   continue
1539 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1540 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1541 C Condition for being inside the proper box
1542 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1543 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1544 c        go to 138
1545 c        endif
1546 c  139   continue
1547 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1548 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1549 C Condition for being inside the proper box
1550 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1551 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1552 c        go to 139
1553 c        endif
1554           xj=mod(xj,boxxsize)
1555           if (xj.lt.0) xj=xj+boxxsize
1556           yj=mod(yj,boxysize)
1557           if (yj.lt.0) yj=yj+boxysize
1558           zj=mod(zj,boxzsize)
1559           if (zj.lt.0) zj=zj+boxzsize
1560       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1561       xj_safe=xj
1562       yj_safe=yj
1563       zj_safe=zj
1564       subchap=0
1565       do xshift=-1,1
1566       do yshift=-1,1
1567       do zshift=-1,1
1568           xj=xj_safe+xshift*boxxsize
1569           yj=yj_safe+yshift*boxysize
1570           zj=zj_safe+zshift*boxzsize
1571           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1572           if(dist_temp.lt.dist_init) then
1573             dist_init=dist_temp
1574             xj_temp=xj
1575             yj_temp=yj
1576             zj_temp=zj
1577             subchap=1
1578           endif
1579        enddo
1580        enddo
1581        enddo
1582        if (subchap.eq.1) then
1583           xj=xj_temp-xi
1584           yj=yj_temp-yi
1585           zj=zj_temp-zi
1586        else
1587           xj=xj_safe-xi
1588           yj=yj_safe-yi
1589           zj=zj_safe-zi
1590        endif
1591             dxj=dc_norm(1,nres+j)
1592             dyj=dc_norm(2,nres+j)
1593             dzj=dc_norm(3,nres+j)
1594 C            xj=xj-xi
1595 C            yj=yj-yi
1596 C            zj=zj-zi
1597 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1598 c            write (iout,*) "j",j," dc_norm",
1599 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1600             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1601             rij=dsqrt(rrij)
1602             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1603             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1604
1605 c            write (iout,'(a7,4f8.3)')
1606 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1607             if (sss.gt.0.0d0) then
1608 C Calculate angle-dependent terms of energy and contributions to their
1609 C derivatives.
1610             call sc_angular
1611             sigsq=1.0D0/sigsq
1612             sig=sig0ij*dsqrt(sigsq)
1613             rij_shift=1.0D0/rij-sig+sig0ij
1614 c for diagnostics; uncomment
1615 c            rij_shift=1.2*sig0ij
1616 C I hate to put IF's in the loops, but here don't have another choice!!!!
1617             if (rij_shift.le.0.0D0) then
1618               evdw=1.0D20
1619 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1620 cd     &        restyp(itypi),i,restyp(itypj),j,
1621 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1622               return
1623             endif
1624             sigder=-sig*sigsq
1625 c---------------------------------------------------------------
1626             rij_shift=1.0D0/rij_shift
1627             fac=rij_shift**expon
1628             e1=fac*fac*aa(itypi,itypj)
1629             e2=fac*bb(itypi,itypj)
1630             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1631             eps2der=evdwij*eps3rt
1632             eps3der=evdwij*eps2rt
1633 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1634 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1635             evdwij=evdwij*eps2rt*eps3rt
1636             evdw=evdw+evdwij*sss
1637             if (lprn) then
1638             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1639             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1640             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1641      &        restyp(itypi),i,restyp(itypj),j,
1642      &        epsi,sigm,chi1,chi2,chip1,chip2,
1643      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1644      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1645      &        evdwij
1646             endif
1647
1648             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1649      &                        'evdw',i,j,evdwij
1650
1651 C Calculate gradient components.
1652             e1=e1*eps1*eps2rt**2*eps3rt**2
1653             fac=-expon*(e1+evdwij)*rij_shift
1654             sigder=fac*sigder
1655             fac=rij*fac
1656 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1657 c     &      evdwij,fac,sigma(itypi,itypj),expon
1658             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1659 c            fac=0.0d0
1660 C Calculate the radial part of the gradient
1661             gg(1)=xj*fac
1662             gg(2)=yj*fac
1663             gg(3)=zj*fac
1664 C Calculate angular part of the gradient.
1665             call sc_grad
1666             endif    ! sss
1667             ENDIF    ! dyn_ss
1668           enddo      ! j
1669         enddo        ! iint
1670       enddo          ! i
1671 C      enddo          ! zshift
1672 C      enddo          ! yshift
1673 C      enddo          ! xshift
1674 c      write (iout,*) "Number of loop steps in EGB:",ind
1675 cccc      energy_dec=.false.
1676       return
1677       end
1678 C-----------------------------------------------------------------------------
1679       subroutine egbv(evdw)
1680 C
1681 C This subroutine calculates the interaction energy of nonbonded side chains
1682 C assuming the Gay-Berne-Vorobjev potential of interaction.
1683 C
1684       implicit real*8 (a-h,o-z)
1685       include 'DIMENSIONS'
1686       include 'COMMON.GEO'
1687       include 'COMMON.VAR'
1688       include 'COMMON.LOCAL'
1689       include 'COMMON.CHAIN'
1690       include 'COMMON.DERIV'
1691       include 'COMMON.NAMES'
1692       include 'COMMON.INTERACT'
1693       include 'COMMON.IOUNITS'
1694       include 'COMMON.CALC'
1695       common /srutu/ icall
1696       logical lprn
1697       evdw=0.0D0
1698 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1699       evdw=0.0D0
1700       lprn=.false.
1701 c     if (icall.eq.0) lprn=.true.
1702       ind=0
1703       do i=iatsc_s,iatsc_e
1704         itypi=iabs(itype(i))
1705         if (itypi.eq.ntyp1) cycle
1706         itypi1=iabs(itype(i+1))
1707         xi=c(1,nres+i)
1708         yi=c(2,nres+i)
1709         zi=c(3,nres+i)
1710         dxi=dc_norm(1,nres+i)
1711         dyi=dc_norm(2,nres+i)
1712         dzi=dc_norm(3,nres+i)
1713 c        dsci_inv=dsc_inv(itypi)
1714         dsci_inv=vbld_inv(i+nres)
1715 C
1716 C Calculate SC interaction energy.
1717 C
1718         do iint=1,nint_gr(i)
1719           do j=istart(i,iint),iend(i,iint)
1720             ind=ind+1
1721             itypj=iabs(itype(j))
1722             if (itypj.eq.ntyp1) cycle
1723 c            dscj_inv=dsc_inv(itypj)
1724             dscj_inv=vbld_inv(j+nres)
1725             sig0ij=sigma(itypi,itypj)
1726             r0ij=r0(itypi,itypj)
1727             chi1=chi(itypi,itypj)
1728             chi2=chi(itypj,itypi)
1729             chi12=chi1*chi2
1730             chip1=chip(itypi)
1731             chip2=chip(itypj)
1732             chip12=chip1*chip2
1733             alf1=alp(itypi)
1734             alf2=alp(itypj)
1735             alf12=0.5D0*(alf1+alf2)
1736 C For diagnostics only!!!
1737 c           chi1=0.0D0
1738 c           chi2=0.0D0
1739 c           chi12=0.0D0
1740 c           chip1=0.0D0
1741 c           chip2=0.0D0
1742 c           chip12=0.0D0
1743 c           alf1=0.0D0
1744 c           alf2=0.0D0
1745 c           alf12=0.0D0
1746             xj=c(1,nres+j)-xi
1747             yj=c(2,nres+j)-yi
1748             zj=c(3,nres+j)-zi
1749             dxj=dc_norm(1,nres+j)
1750             dyj=dc_norm(2,nres+j)
1751             dzj=dc_norm(3,nres+j)
1752             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1753             rij=dsqrt(rrij)
1754 C Calculate angle-dependent terms of energy and contributions to their
1755 C derivatives.
1756             call sc_angular
1757             sigsq=1.0D0/sigsq
1758             sig=sig0ij*dsqrt(sigsq)
1759             rij_shift=1.0D0/rij-sig+r0ij
1760 C I hate to put IF's in the loops, but here don't have another choice!!!!
1761             if (rij_shift.le.0.0D0) then
1762               evdw=1.0D20
1763               return
1764             endif
1765             sigder=-sig*sigsq
1766 c---------------------------------------------------------------
1767             rij_shift=1.0D0/rij_shift
1768             fac=rij_shift**expon
1769             e1=fac*fac*aa(itypi,itypj)
1770             e2=fac*bb(itypi,itypj)
1771             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1772             eps2der=evdwij*eps3rt
1773             eps3der=evdwij*eps2rt
1774             fac_augm=rrij**expon
1775             e_augm=augm(itypi,itypj)*fac_augm
1776             evdwij=evdwij*eps2rt*eps3rt
1777             evdw=evdw+evdwij+e_augm
1778             if (lprn) then
1779             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1780             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1781             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1782      &        restyp(itypi),i,restyp(itypj),j,
1783      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1784      &        chi1,chi2,chip1,chip2,
1785      &        eps1,eps2rt**2,eps3rt**2,
1786      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1787      &        evdwij+e_augm
1788             endif
1789 C Calculate gradient components.
1790             e1=e1*eps1*eps2rt**2*eps3rt**2
1791             fac=-expon*(e1+evdwij)*rij_shift
1792             sigder=fac*sigder
1793             fac=rij*fac-2*expon*rrij*e_augm
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799             call sc_grad
1800           enddo      ! j
1801         enddo        ! iint
1802       enddo          ! i
1803       end
1804 C-----------------------------------------------------------------------------
1805       subroutine sc_angular
1806 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1807 C om12. Called by ebp, egb, and egbv.
1808       implicit none
1809       include 'COMMON.CALC'
1810       include 'COMMON.IOUNITS'
1811       erij(1)=xj*rij
1812       erij(2)=yj*rij
1813       erij(3)=zj*rij
1814       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1815       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1816       om12=dxi*dxj+dyi*dyj+dzi*dzj
1817       chiom12=chi12*om12
1818 C Calculate eps1(om12) and its derivative in om12
1819       faceps1=1.0D0-om12*chiom12
1820       faceps1_inv=1.0D0/faceps1
1821       eps1=dsqrt(faceps1_inv)
1822 C Following variable is eps1*deps1/dom12
1823       eps1_om12=faceps1_inv*chiom12
1824 c diagnostics only
1825 c      faceps1_inv=om12
1826 c      eps1=om12
1827 c      eps1_om12=1.0d0
1828 c      write (iout,*) "om12",om12," eps1",eps1
1829 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1830 C and om12.
1831       om1om2=om1*om2
1832       chiom1=chi1*om1
1833       chiom2=chi2*om2
1834       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1835       sigsq=1.0D0-facsig*faceps1_inv
1836       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1837       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1838       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1839 c diagnostics only
1840 c      sigsq=1.0d0
1841 c      sigsq_om1=0.0d0
1842 c      sigsq_om2=0.0d0
1843 c      sigsq_om12=0.0d0
1844 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1845 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1846 c     &    " eps1",eps1
1847 C Calculate eps2 and its derivatives in om1, om2, and om12.
1848       chipom1=chip1*om1
1849       chipom2=chip2*om2
1850       chipom12=chip12*om12
1851       facp=1.0D0-om12*chipom12
1852       facp_inv=1.0D0/facp
1853       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1854 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1855 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1856 C Following variable is the square root of eps2
1857       eps2rt=1.0D0-facp1*facp_inv
1858 C Following three variables are the derivatives of the square root of eps
1859 C in om1, om2, and om12.
1860       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1861       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1862       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1863 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1864       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1865 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1866 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1867 c     &  " eps2rt_om12",eps2rt_om12
1868 C Calculate whole angle-dependent part of epsilon and contributions
1869 C to its derivatives
1870       return
1871       end
1872 C----------------------------------------------------------------------------
1873       subroutine sc_grad
1874       implicit real*8 (a-h,o-z)
1875       include 'DIMENSIONS'
1876       include 'COMMON.CHAIN'
1877       include 'COMMON.DERIV'
1878       include 'COMMON.CALC'
1879       include 'COMMON.IOUNITS'
1880       double precision dcosom1(3),dcosom2(3)
1881 cc      print *,'sss=',sss
1882       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1883       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1884       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1885      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1886 c diagnostics only
1887 c      eom1=0.0d0
1888 c      eom2=0.0d0
1889 c      eom12=evdwij*eps1_om12
1890 c end diagnostics
1891 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1892 c     &  " sigder",sigder
1893 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1894 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1895       do k=1,3
1896         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1897         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1898       enddo
1899       do k=1,3
1900         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1901       enddo
1902 c      write (iout,*) "gg",(gg(k),k=1,3)
1903       do k=1,3
1904         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1905      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1906      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1907         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1908      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1909      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1910 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1911 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1912 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1913 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1914       enddo
1915 C
1916 C Calculate the components of the gradient in DC and X
1917 C
1918 cgrad      do k=i,j-1
1919 cgrad        do l=1,3
1920 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1921 cgrad        enddo
1922 cgrad      enddo
1923       do l=1,3
1924         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1925         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1926       enddo
1927       return
1928       end
1929 C-----------------------------------------------------------------------
1930       subroutine e_softsphere(evdw)
1931 C
1932 C This subroutine calculates the interaction energy of nonbonded side chains
1933 C assuming the LJ potential of interaction.
1934 C
1935       implicit real*8 (a-h,o-z)
1936       include 'DIMENSIONS'
1937       parameter (accur=1.0d-10)
1938       include 'COMMON.GEO'
1939       include 'COMMON.VAR'
1940       include 'COMMON.LOCAL'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.INTERACT'
1944       include 'COMMON.TORSION'
1945       include 'COMMON.SBRIDGE'
1946       include 'COMMON.NAMES'
1947       include 'COMMON.IOUNITS'
1948       include 'COMMON.CONTACTS'
1949       dimension gg(3)
1950 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1951       evdw=0.0D0
1952       do i=iatsc_s,iatsc_e
1953         itypi=iabs(itype(i))
1954         if (itypi.eq.ntyp1) cycle
1955         itypi1=iabs(itype(i+1))
1956         xi=c(1,nres+i)
1957         yi=c(2,nres+i)
1958         zi=c(3,nres+i)
1959 C
1960 C Calculate SC interaction energy.
1961 C
1962         do iint=1,nint_gr(i)
1963 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1964 cd   &                  'iend=',iend(i,iint)
1965           do j=istart(i,iint),iend(i,iint)
1966             itypj=iabs(itype(j))
1967             if (itypj.eq.ntyp1) cycle
1968             xj=c(1,nres+j)-xi
1969             yj=c(2,nres+j)-yi
1970             zj=c(3,nres+j)-zi
1971             rij=xj*xj+yj*yj+zj*zj
1972 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1973             r0ij=r0(itypi,itypj)
1974             r0ijsq=r0ij*r0ij
1975 c            print *,i,j,r0ij,dsqrt(rij)
1976             if (rij.lt.r0ijsq) then
1977               evdwij=0.25d0*(rij-r0ijsq)**2
1978               fac=rij-r0ijsq
1979             else
1980               evdwij=0.0d0
1981               fac=0.0d0
1982             endif
1983             evdw=evdw+evdwij
1984 C
1985 C Calculate the components of the gradient in DC and X
1986 C
1987             gg(1)=xj*fac
1988             gg(2)=yj*fac
1989             gg(3)=zj*fac
1990             do k=1,3
1991               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1992               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1993               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1994               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1995             enddo
1996 cgrad            do k=i,j-1
1997 cgrad              do l=1,3
1998 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1999 cgrad              enddo
2000 cgrad            enddo
2001           enddo ! j
2002         enddo ! iint
2003       enddo ! i
2004       return
2005       end
2006 C--------------------------------------------------------------------------
2007       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2008      &              eello_turn4)
2009 C
2010 C Soft-sphere potential of p-p interaction
2011 C
2012       implicit real*8 (a-h,o-z)
2013       include 'DIMENSIONS'
2014       include 'COMMON.CONTROL'
2015       include 'COMMON.IOUNITS'
2016       include 'COMMON.GEO'
2017       include 'COMMON.VAR'
2018       include 'COMMON.LOCAL'
2019       include 'COMMON.CHAIN'
2020       include 'COMMON.DERIV'
2021       include 'COMMON.INTERACT'
2022       include 'COMMON.CONTACTS'
2023       include 'COMMON.TORSION'
2024       include 'COMMON.VECTORS'
2025       include 'COMMON.FFIELD'
2026       dimension ggg(3)
2027 C      write(iout,*) 'In EELEC_soft_sphere'
2028       ees=0.0D0
2029       evdw1=0.0D0
2030       eel_loc=0.0d0
2031       eello_turn3=0.0d0
2032       eello_turn4=0.0d0
2033       ind=0
2034       do i=iatel_s,iatel_e
2035         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2036         dxi=dc(1,i)
2037         dyi=dc(2,i)
2038         dzi=dc(3,i)
2039         xmedi=c(1,i)+0.5d0*dxi
2040         ymedi=c(2,i)+0.5d0*dyi
2041         zmedi=c(3,i)+0.5d0*dzi
2042           xmedi=mod(xmedi,boxxsize)
2043           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2044           ymedi=mod(ymedi,boxysize)
2045           if (ymedi.lt.0) ymedi=ymedi+boxysize
2046           zmedi=mod(zmedi,boxzsize)
2047           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2048         num_conti=0
2049 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2050         do j=ielstart(i),ielend(i)
2051           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2052           ind=ind+1
2053           iteli=itel(i)
2054           itelj=itel(j)
2055           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2056           r0ij=rpp(iteli,itelj)
2057           r0ijsq=r0ij*r0ij
2058           dxj=dc(1,j)
2059           dyj=dc(2,j)
2060           dzj=dc(3,j)
2061           xj=c(1,j)+0.5D0*dxj
2062           yj=c(2,j)+0.5D0*dyj
2063           zj=c(3,j)+0.5D0*dzj
2064           xj=mod(xj,boxxsize)
2065           if (xj.lt.0) xj=xj+boxxsize
2066           yj=mod(yj,boxysize)
2067           if (yj.lt.0) yj=yj+boxysize
2068           zj=mod(zj,boxzsize)
2069           if (zj.lt.0) zj=zj+boxzsize
2070       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2071       xj_safe=xj
2072       yj_safe=yj
2073       zj_safe=zj
2074       isubchap=0
2075       do xshift=-1,1
2076       do yshift=-1,1
2077       do zshift=-1,1
2078           xj=xj_safe+xshift*boxxsize
2079           yj=yj_safe+yshift*boxysize
2080           zj=zj_safe+zshift*boxzsize
2081           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2082           if(dist_temp.lt.dist_init) then
2083             dist_init=dist_temp
2084             xj_temp=xj
2085             yj_temp=yj
2086             zj_temp=zj
2087             isubchap=1
2088           endif
2089        enddo
2090        enddo
2091        enddo
2092        if (isubchap.eq.1) then
2093           xj=xj_temp-xmedi
2094           yj=yj_temp-ymedi
2095           zj=zj_temp-zmedi
2096        else
2097           xj=xj_safe-xmedi
2098           yj=yj_safe-ymedi
2099           zj=zj_safe-zmedi
2100        endif
2101           rij=xj*xj+yj*yj+zj*zj
2102             sss=sscale(sqrt(rij))
2103             sssgrad=sscagrad(sqrt(rij))
2104           if (rij.lt.r0ijsq) then
2105             evdw1ij=0.25d0*(rij-r0ijsq)**2
2106             fac=rij-r0ijsq
2107           else
2108             evdw1ij=0.0d0
2109             fac=0.0d0
2110           endif
2111           evdw1=evdw1+evdw1ij*sss
2112 C
2113 C Calculate contributions to the Cartesian gradient.
2114 C
2115           ggg(1)=fac*xj*sssgrad
2116           ggg(2)=fac*yj*sssgrad
2117           ggg(3)=fac*zj*sssgrad
2118           do k=1,3
2119             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2120             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2121           enddo
2122 *
2123 * Loop over residues i+1 thru j-1.
2124 *
2125 cgrad          do k=i+1,j-1
2126 cgrad            do l=1,3
2127 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2128 cgrad            enddo
2129 cgrad          enddo
2130         enddo ! j
2131       enddo   ! i
2132 cgrad      do i=nnt,nct-1
2133 cgrad        do k=1,3
2134 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2135 cgrad        enddo
2136 cgrad        do j=i+1,nct-1
2137 cgrad          do k=1,3
2138 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2139 cgrad          enddo
2140 cgrad        enddo
2141 cgrad      enddo
2142       return
2143       end
2144 c------------------------------------------------------------------------------
2145       subroutine vec_and_deriv
2146       implicit real*8 (a-h,o-z)
2147       include 'DIMENSIONS'
2148 #ifdef MPI
2149       include 'mpif.h'
2150 #endif
2151       include 'COMMON.IOUNITS'
2152       include 'COMMON.GEO'
2153       include 'COMMON.VAR'
2154       include 'COMMON.LOCAL'
2155       include 'COMMON.CHAIN'
2156       include 'COMMON.VECTORS'
2157       include 'COMMON.SETUP'
2158       include 'COMMON.TIME1'
2159       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2160 C Compute the local reference systems. For reference system (i), the
2161 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2162 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2163 #ifdef PARVEC
2164       do i=ivec_start,ivec_end
2165 #else
2166       do i=1,nres-1
2167 #endif
2168           if (i.eq.nres-1) then
2169 C Case of the last full residue
2170 C Compute the Z-axis
2171             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2172             costh=dcos(pi-theta(nres))
2173             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2174             do k=1,3
2175               uz(k,i)=fac*uz(k,i)
2176             enddo
2177 C Compute the derivatives of uz
2178             uzder(1,1,1)= 0.0d0
2179             uzder(2,1,1)=-dc_norm(3,i-1)
2180             uzder(3,1,1)= dc_norm(2,i-1)
2181             uzder(1,2,1)= dc_norm(3,i-1)
2182             uzder(2,2,1)= 0.0d0
2183             uzder(3,2,1)=-dc_norm(1,i-1)
2184             uzder(1,3,1)=-dc_norm(2,i-1)
2185             uzder(2,3,1)= dc_norm(1,i-1)
2186             uzder(3,3,1)= 0.0d0
2187             uzder(1,1,2)= 0.0d0
2188             uzder(2,1,2)= dc_norm(3,i)
2189             uzder(3,1,2)=-dc_norm(2,i)
2190             uzder(1,2,2)=-dc_norm(3,i)
2191             uzder(2,2,2)= 0.0d0
2192             uzder(3,2,2)= dc_norm(1,i)
2193             uzder(1,3,2)= dc_norm(2,i)
2194             uzder(2,3,2)=-dc_norm(1,i)
2195             uzder(3,3,2)= 0.0d0
2196 C Compute the Y-axis
2197             facy=fac
2198             do k=1,3
2199               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2200             enddo
2201 C Compute the derivatives of uy
2202             do j=1,3
2203               do k=1,3
2204                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2205      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2206                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2207               enddo
2208               uyder(j,j,1)=uyder(j,j,1)-costh
2209               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2210             enddo
2211             do j=1,2
2212               do k=1,3
2213                 do l=1,3
2214                   uygrad(l,k,j,i)=uyder(l,k,j)
2215                   uzgrad(l,k,j,i)=uzder(l,k,j)
2216                 enddo
2217               enddo
2218             enddo
2219             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2220             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2221             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2222             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2223           else
2224 C Other residues
2225 C Compute the Z-axis
2226             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2227             costh=dcos(pi-theta(i+2))
2228             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2229             do k=1,3
2230               uz(k,i)=fac*uz(k,i)
2231             enddo
2232 C Compute the derivatives of uz
2233             uzder(1,1,1)= 0.0d0
2234             uzder(2,1,1)=-dc_norm(3,i+1)
2235             uzder(3,1,1)= dc_norm(2,i+1)
2236             uzder(1,2,1)= dc_norm(3,i+1)
2237             uzder(2,2,1)= 0.0d0
2238             uzder(3,2,1)=-dc_norm(1,i+1)
2239             uzder(1,3,1)=-dc_norm(2,i+1)
2240             uzder(2,3,1)= dc_norm(1,i+1)
2241             uzder(3,3,1)= 0.0d0
2242             uzder(1,1,2)= 0.0d0
2243             uzder(2,1,2)= dc_norm(3,i)
2244             uzder(3,1,2)=-dc_norm(2,i)
2245             uzder(1,2,2)=-dc_norm(3,i)
2246             uzder(2,2,2)= 0.0d0
2247             uzder(3,2,2)= dc_norm(1,i)
2248             uzder(1,3,2)= dc_norm(2,i)
2249             uzder(2,3,2)=-dc_norm(1,i)
2250             uzder(3,3,2)= 0.0d0
2251 C Compute the Y-axis
2252             facy=fac
2253             do k=1,3
2254               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2255             enddo
2256 C Compute the derivatives of uy
2257             do j=1,3
2258               do k=1,3
2259                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2260      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2261                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2262               enddo
2263               uyder(j,j,1)=uyder(j,j,1)-costh
2264               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2265             enddo
2266             do j=1,2
2267               do k=1,3
2268                 do l=1,3
2269                   uygrad(l,k,j,i)=uyder(l,k,j)
2270                   uzgrad(l,k,j,i)=uzder(l,k,j)
2271                 enddo
2272               enddo
2273             enddo
2274             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2275             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2276             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2277             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2278           endif
2279       enddo
2280       do i=1,nres-1
2281         vbld_inv_temp(1)=vbld_inv(i+1)
2282         if (i.lt.nres-1) then
2283           vbld_inv_temp(2)=vbld_inv(i+2)
2284           else
2285           vbld_inv_temp(2)=vbld_inv(i)
2286           endif
2287         do j=1,2
2288           do k=1,3
2289             do l=1,3
2290               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2291               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2292             enddo
2293           enddo
2294         enddo
2295       enddo
2296 #if defined(PARVEC) && defined(MPI)
2297       if (nfgtasks1.gt.1) then
2298         time00=MPI_Wtime()
2299 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2300 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2301 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2302         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2303      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2304      &   FG_COMM1,IERR)
2305         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2306      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2307      &   FG_COMM1,IERR)
2308         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2309      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2310      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2311         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2312      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2313      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2314         time_gather=time_gather+MPI_Wtime()-time00
2315       endif
2316 c      if (fg_rank.eq.0) then
2317 c        write (iout,*) "Arrays UY and UZ"
2318 c        do i=1,nres-1
2319 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2320 c     &     (uz(k,i),k=1,3)
2321 c        enddo
2322 c      endif
2323 #endif
2324       return
2325       end
2326 C-----------------------------------------------------------------------------
2327       subroutine check_vecgrad
2328       implicit real*8 (a-h,o-z)
2329       include 'DIMENSIONS'
2330       include 'COMMON.IOUNITS'
2331       include 'COMMON.GEO'
2332       include 'COMMON.VAR'
2333       include 'COMMON.LOCAL'
2334       include 'COMMON.CHAIN'
2335       include 'COMMON.VECTORS'
2336       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2337       dimension uyt(3,maxres),uzt(3,maxres)
2338       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2339       double precision delta /1.0d-7/
2340       call vec_and_deriv
2341 cd      do i=1,nres
2342 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2343 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2344 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2345 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2346 cd     &     (dc_norm(if90,i),if90=1,3)
2347 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2348 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2349 cd          write(iout,'(a)')
2350 cd      enddo
2351       do i=1,nres
2352         do j=1,2
2353           do k=1,3
2354             do l=1,3
2355               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2356               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2357             enddo
2358           enddo
2359         enddo
2360       enddo
2361       call vec_and_deriv
2362       do i=1,nres
2363         do j=1,3
2364           uyt(j,i)=uy(j,i)
2365           uzt(j,i)=uz(j,i)
2366         enddo
2367       enddo
2368       do i=1,nres
2369 cd        write (iout,*) 'i=',i
2370         do k=1,3
2371           erij(k)=dc_norm(k,i)
2372         enddo
2373         do j=1,3
2374           do k=1,3
2375             dc_norm(k,i)=erij(k)
2376           enddo
2377           dc_norm(j,i)=dc_norm(j,i)+delta
2378 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2379 c          do k=1,3
2380 c            dc_norm(k,i)=dc_norm(k,i)/fac
2381 c          enddo
2382 c          write (iout,*) (dc_norm(k,i),k=1,3)
2383 c          write (iout,*) (erij(k),k=1,3)
2384           call vec_and_deriv
2385           do k=1,3
2386             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2387             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2388             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2389             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2390           enddo
2391 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2392 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2393 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2394         enddo
2395         do k=1,3
2396           dc_norm(k,i)=erij(k)
2397         enddo
2398 cd        do k=1,3
2399 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2400 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2401 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2402 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2403 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2404 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2405 cd          write (iout,'(a)')
2406 cd        enddo
2407       enddo
2408       return
2409       end
2410 C--------------------------------------------------------------------------
2411       subroutine set_matrices
2412       implicit real*8 (a-h,o-z)
2413       include 'DIMENSIONS'
2414 #ifdef MPI
2415       include "mpif.h"
2416       include "COMMON.SETUP"
2417       integer IERR
2418       integer status(MPI_STATUS_SIZE)
2419 #endif
2420       include 'COMMON.IOUNITS'
2421       include 'COMMON.GEO'
2422       include 'COMMON.VAR'
2423       include 'COMMON.LOCAL'
2424       include 'COMMON.CHAIN'
2425       include 'COMMON.DERIV'
2426       include 'COMMON.INTERACT'
2427       include 'COMMON.CONTACTS'
2428       include 'COMMON.TORSION'
2429       include 'COMMON.VECTORS'
2430       include 'COMMON.FFIELD'
2431       double precision auxvec(2),auxmat(2,2)
2432 C
2433 C Compute the virtual-bond-torsional-angle dependent quantities needed
2434 C to calculate the el-loc multibody terms of various order.
2435 C
2436 c      write(iout,*) 'nphi=',nphi,nres
2437 #ifdef PARMAT
2438       do i=ivec_start+2,ivec_end+2
2439 #else
2440       do i=3,nres+1
2441 #endif
2442 #ifdef NEWCORR
2443         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2444           iti = itortyp(itype(i-2))
2445         else
2446           iti=ntortyp+1
2447         endif
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           iti1 = itortyp(itype(i-1))
2451         else
2452           iti1=ntortyp+1
2453         endif
2454 c        write(iout,*),i
2455         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2456      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2457      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2458         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2459      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2460      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2461 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2462 c     &*(cos(theta(i)/2.0)
2463         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2464      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2465      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2466 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2467 c     &*(cos(theta(i)/2.0)
2468         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2469      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2470      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2471 c        if (ggb1(1,i).eq.0.0d0) then
2472 c        write(iout,*) 'i=',i,ggb1(1,i),
2473 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2474 c     &bnew1(2,1,iti)*cos(theta(i)),
2475 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2476 c        endif
2477         b1(2,i-2)=bnew1(1,2,iti)
2478         gtb1(2,i-2)=0.0
2479         b2(2,i-2)=bnew2(1,2,iti)
2480         gtb2(2,i-2)=0.0
2481         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2482         EE(1,2,i-2)=eeold(1,2,iti)
2483         EE(2,1,i-2)=eeold(2,1,iti)
2484         EE(2,2,i-2)=eeold(2,2,iti)
2485         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2486         gtEE(1,2,i-2)=0.0d0
2487         gtEE(2,2,i-2)=0.0d0
2488         gtEE(2,1,i-2)=0.0d0
2489 c        EE(2,2,iti)=0.0d0
2490 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2491 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2492 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2493 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2494        b1tilde(1,i-2)=b1(1,i-2)
2495        b1tilde(2,i-2)=-b1(2,i-2)
2496        b2tilde(1,i-2)=b2(1,i-2)
2497        b2tilde(2,i-2)=-b2(2,i-2)
2498 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2499 c       write(iout,*)  'b1=',b1(1,i-2)
2500 c       write (iout,*) 'theta=', theta(i-1)
2501        enddo
2502 #else
2503         b1(1,i-2)=b(3,iti)
2504         b1(2,i-2)=b(5,iti)
2505         b2(1,i-2)=b(2,iti)
2506         b2(2,i-2)=b(4,iti)
2507        b1tilde(1,i-2)=b1(1,i-2)
2508        b1tilde(2,i-2)=-b1(2,i-2)
2509        b2tilde(1,i-2)=b2(1,i-2)
2510        b2tilde(2,i-2)=-b2(2,i-2)
2511         EE(1,2,i-2)=eeold(1,2,iti)
2512         EE(2,1,i-2)=eeold(2,1,iti)
2513         EE(2,2,i-2)=eeold(2,2,iti)
2514         EE(1,1,i-2)=eeold(1,1,iti)
2515       enddo
2516 #endif
2517 #ifdef PARMAT
2518       do i=ivec_start+2,ivec_end+2
2519 #else
2520       do i=3,nres+1
2521 #endif
2522         if (i .lt. nres+1) then
2523           sin1=dsin(phi(i))
2524           cos1=dcos(phi(i))
2525           sintab(i-2)=sin1
2526           costab(i-2)=cos1
2527           obrot(1,i-2)=cos1
2528           obrot(2,i-2)=sin1
2529           sin2=dsin(2*phi(i))
2530           cos2=dcos(2*phi(i))
2531           sintab2(i-2)=sin2
2532           costab2(i-2)=cos2
2533           obrot2(1,i-2)=cos2
2534           obrot2(2,i-2)=sin2
2535           Ug(1,1,i-2)=-cos1
2536           Ug(1,2,i-2)=-sin1
2537           Ug(2,1,i-2)=-sin1
2538           Ug(2,2,i-2)= cos1
2539           Ug2(1,1,i-2)=-cos2
2540           Ug2(1,2,i-2)=-sin2
2541           Ug2(2,1,i-2)=-sin2
2542           Ug2(2,2,i-2)= cos2
2543         else
2544           costab(i-2)=1.0d0
2545           sintab(i-2)=0.0d0
2546           obrot(1,i-2)=1.0d0
2547           obrot(2,i-2)=0.0d0
2548           obrot2(1,i-2)=0.0d0
2549           obrot2(2,i-2)=0.0d0
2550           Ug(1,1,i-2)=1.0d0
2551           Ug(1,2,i-2)=0.0d0
2552           Ug(2,1,i-2)=0.0d0
2553           Ug(2,2,i-2)=1.0d0
2554           Ug2(1,1,i-2)=0.0d0
2555           Ug2(1,2,i-2)=0.0d0
2556           Ug2(2,1,i-2)=0.0d0
2557           Ug2(2,2,i-2)=0.0d0
2558         endif
2559         if (i .gt. 3 .and. i .lt. nres+1) then
2560           obrot_der(1,i-2)=-sin1
2561           obrot_der(2,i-2)= cos1
2562           Ugder(1,1,i-2)= sin1
2563           Ugder(1,2,i-2)=-cos1
2564           Ugder(2,1,i-2)=-cos1
2565           Ugder(2,2,i-2)=-sin1
2566           dwacos2=cos2+cos2
2567           dwasin2=sin2+sin2
2568           obrot2_der(1,i-2)=-dwasin2
2569           obrot2_der(2,i-2)= dwacos2
2570           Ug2der(1,1,i-2)= dwasin2
2571           Ug2der(1,2,i-2)=-dwacos2
2572           Ug2der(2,1,i-2)=-dwacos2
2573           Ug2der(2,2,i-2)=-dwasin2
2574         else
2575           obrot_der(1,i-2)=0.0d0
2576           obrot_der(2,i-2)=0.0d0
2577           Ugder(1,1,i-2)=0.0d0
2578           Ugder(1,2,i-2)=0.0d0
2579           Ugder(2,1,i-2)=0.0d0
2580           Ugder(2,2,i-2)=0.0d0
2581           obrot2_der(1,i-2)=0.0d0
2582           obrot2_der(2,i-2)=0.0d0
2583           Ug2der(1,1,i-2)=0.0d0
2584           Ug2der(1,2,i-2)=0.0d0
2585           Ug2der(2,1,i-2)=0.0d0
2586           Ug2der(2,2,i-2)=0.0d0
2587         endif
2588 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2589         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2590           iti = itortyp(itype(i-2))
2591         else
2592           iti=ntortyp
2593         endif
2594 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2595         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2596           iti1 = itortyp(itype(i-1))
2597         else
2598           iti1=ntortyp
2599         endif
2600 cd        write (iout,*) '*******i',i,' iti1',iti
2601 cd        write (iout,*) 'b1',b1(:,iti)
2602 cd        write (iout,*) 'b2',b2(:,iti)
2603 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2604 c        if (i .gt. iatel_s+2) then
2605         if (i .gt. nnt+2) then
2606           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2607 #ifdef NEWCORR
2608           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2609 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2610 #endif
2611 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2612 c     &    EE(1,2,iti),EE(2,2,iti)
2613           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2614           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2615 c          write(iout,*) "Macierz EUG",
2616 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2617 c     &    eug(2,2,i-2)
2618           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2619      &    then
2620           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2621           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2622           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2623           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2624           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2625           endif
2626         else
2627           do k=1,2
2628             Ub2(k,i-2)=0.0d0
2629             Ctobr(k,i-2)=0.0d0
2630             Dtobr2(k,i-2)=0.0d0
2631             do l=1,2
2632               EUg(l,k,i-2)=0.0d0
2633               CUg(l,k,i-2)=0.0d0
2634               DUg(l,k,i-2)=0.0d0
2635               DtUg2(l,k,i-2)=0.0d0
2636             enddo
2637           enddo
2638         endif
2639         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2640         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2641         do k=1,2
2642           muder(k,i-2)=Ub2der(k,i-2)
2643         enddo
2644 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2645         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2646           if (itype(i-1).le.ntyp) then
2647             iti1 = itortyp(itype(i-1))
2648           else
2649             iti1=ntortyp
2650           endif
2651         else
2652           iti1=ntortyp
2653         endif
2654         do k=1,2
2655           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2656         enddo
2657 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2658 cd        write (iout,*) 'mu1',mu1(:,i-2)
2659 cd        write (iout,*) 'mu2',mu2(:,i-2)
2660         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2661      &  then
2662         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2663         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2664         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2665         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2666         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2667 C Vectors and matrices dependent on a single virtual-bond dihedral.
2668         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2669         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2670         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2671         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2672         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2673         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2674         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2675         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2676         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2677         endif
2678       enddo
2679 C Matrices dependent on two consecutive virtual-bond dihedrals.
2680 C The order of matrices is from left to right.
2681       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2682      &then
2683 c      do i=max0(ivec_start,2),ivec_end
2684       do i=2,nres-1
2685         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2686         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2687         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2688         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2689         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2690         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2691         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2692         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2693       enddo
2694       endif
2695 #if defined(MPI) && defined(PARMAT)
2696 #ifdef DEBUG
2697 c      if (fg_rank.eq.0) then
2698         write (iout,*) "Arrays UG and UGDER before GATHER"
2699         do i=1,nres-1
2700           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2701      &     ((ug(l,k,i),l=1,2),k=1,2),
2702      &     ((ugder(l,k,i),l=1,2),k=1,2)
2703         enddo
2704         write (iout,*) "Arrays UG2 and UG2DER"
2705         do i=1,nres-1
2706           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2707      &     ((ug2(l,k,i),l=1,2),k=1,2),
2708      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2709         enddo
2710         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2711         do i=1,nres-1
2712           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2713      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2714      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2715         enddo
2716         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2717         do i=1,nres-1
2718           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2719      &     costab(i),sintab(i),costab2(i),sintab2(i)
2720         enddo
2721         write (iout,*) "Array MUDER"
2722         do i=1,nres-1
2723           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2724         enddo
2725 c      endif
2726 #endif
2727       if (nfgtasks.gt.1) then
2728         time00=MPI_Wtime()
2729 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2730 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2731 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2732 #ifdef MATGATHER
2733         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2752      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2753      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2754         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2755      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2756      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2757         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2758      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2759      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2760         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2761      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2762      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2763         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2764      &  then
2765         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2770      &   FG_COMM1,IERR)
2771         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2773      &   FG_COMM1,IERR)
2774        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2781      &   ivec_count(fg_rank1),
2782      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2795      &   FG_COMM1,IERR)
2796         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2800      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2801      &   FG_COMM1,IERR)
2802         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2803      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2804      &   FG_COMM1,IERR)
2805         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2806      &   ivec_count(fg_rank1),
2807      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2816      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2817      &   FG_COMM1,IERR)
2818        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2819      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2820      &   FG_COMM1,IERR)
2821         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2822      &   ivec_count(fg_rank1),
2823      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2824      &   FG_COMM1,IERR)
2825         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2826      &   ivec_count(fg_rank1),
2827      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2828      &   FG_COMM1,IERR)
2829         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2830      &   ivec_count(fg_rank1),
2831      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2832      &   MPI_MAT2,FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2834      &   ivec_count(fg_rank1),
2835      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2836      &   MPI_MAT2,FG_COMM1,IERR)
2837         endif
2838 #else
2839 c Passes matrix info through the ring
2840       isend=fg_rank1
2841       irecv=fg_rank1-1
2842       if (irecv.lt.0) irecv=nfgtasks1-1
2843       iprev=irecv
2844       inext=fg_rank1+1
2845       if (inext.ge.nfgtasks1) inext=0
2846       do i=1,nfgtasks1-1
2847 c        write (iout,*) "isend",isend," irecv",irecv
2848 c        call flush(iout)
2849         lensend=lentyp(isend)
2850         lenrecv=lentyp(irecv)
2851 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2852 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2853 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2854 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2855 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2856 c        write (iout,*) "Gather ROTAT1"
2857 c        call flush(iout)
2858 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2859 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2860 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2861 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2862 c        write (iout,*) "Gather ROTAT2"
2863 c        call flush(iout)
2864         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2865      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2866      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2867      &   iprev,4400+irecv,FG_COMM,status,IERR)
2868 c        write (iout,*) "Gather ROTAT_OLD"
2869 c        call flush(iout)
2870         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2871      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2872      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2873      &   iprev,5500+irecv,FG_COMM,status,IERR)
2874 c        write (iout,*) "Gather PRECOMP11"
2875 c        call flush(iout)
2876         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2877      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2878      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2879      &   iprev,6600+irecv,FG_COMM,status,IERR)
2880 c        write (iout,*) "Gather PRECOMP12"
2881 c        call flush(iout)
2882         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2883      &  then
2884         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2885      &   MPI_ROTAT2(lensend),inext,7700+isend,
2886      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2887      &   iprev,7700+irecv,FG_COMM,status,IERR)
2888 c        write (iout,*) "Gather PRECOMP21"
2889 c        call flush(iout)
2890         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2891      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2892      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2893      &   iprev,8800+irecv,FG_COMM,status,IERR)
2894 c        write (iout,*) "Gather PRECOMP22"
2895 c        call flush(iout)
2896         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2897      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2898      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2899      &   MPI_PRECOMP23(lenrecv),
2900      &   iprev,9900+irecv,FG_COMM,status,IERR)
2901 c        write (iout,*) "Gather PRECOMP23"
2902 c        call flush(iout)
2903         endif
2904         isend=irecv
2905         irecv=irecv-1
2906         if (irecv.lt.0) irecv=nfgtasks1-1
2907       enddo
2908 #endif
2909         time_gather=time_gather+MPI_Wtime()-time00
2910       endif
2911 #ifdef DEBUG
2912 c      if (fg_rank.eq.0) then
2913         write (iout,*) "Arrays UG and UGDER"
2914         do i=1,nres-1
2915           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2916      &     ((ug(l,k,i),l=1,2),k=1,2),
2917      &     ((ugder(l,k,i),l=1,2),k=1,2)
2918         enddo
2919         write (iout,*) "Arrays UG2 and UG2DER"
2920         do i=1,nres-1
2921           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2922      &     ((ug2(l,k,i),l=1,2),k=1,2),
2923      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2924         enddo
2925         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2926         do i=1,nres-1
2927           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2928      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2929      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2930         enddo
2931         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2932         do i=1,nres-1
2933           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2934      &     costab(i),sintab(i),costab2(i),sintab2(i)
2935         enddo
2936         write (iout,*) "Array MUDER"
2937         do i=1,nres-1
2938           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2939         enddo
2940 c      endif
2941 #endif
2942 #endif
2943 cd      do i=1,nres
2944 cd        iti = itortyp(itype(i))
2945 cd        write (iout,*) i
2946 cd        do j=1,2
2947 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2948 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2949 cd        enddo
2950 cd      enddo
2951       return
2952       end
2953 C--------------------------------------------------------------------------
2954       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2955 C
2956 C This subroutine calculates the average interaction energy and its gradient
2957 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2958 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2959 C The potential depends both on the distance of peptide-group centers and on
2960 C the orientation of the CA-CA virtual bonds.
2961 C
2962       implicit real*8 (a-h,o-z)
2963 #ifdef MPI
2964       include 'mpif.h'
2965 #endif
2966       include 'DIMENSIONS'
2967       include 'COMMON.CONTROL'
2968       include 'COMMON.SETUP'
2969       include 'COMMON.IOUNITS'
2970       include 'COMMON.GEO'
2971       include 'COMMON.VAR'
2972       include 'COMMON.LOCAL'
2973       include 'COMMON.CHAIN'
2974       include 'COMMON.DERIV'
2975       include 'COMMON.INTERACT'
2976       include 'COMMON.CONTACTS'
2977       include 'COMMON.TORSION'
2978       include 'COMMON.VECTORS'
2979       include 'COMMON.FFIELD'
2980       include 'COMMON.TIME1'
2981       include 'COMMON.SPLITELE'
2982       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2983      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2984       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2985      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2986       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2987      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2988      &    num_conti,j1,j2
2989 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2990 #ifdef MOMENT
2991       double precision scal_el /1.0d0/
2992 #else
2993       double precision scal_el /0.5d0/
2994 #endif
2995 C 12/13/98
2996 C 13-go grudnia roku pamietnego...
2997       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2998      &                   0.0d0,1.0d0,0.0d0,
2999      &                   0.0d0,0.0d0,1.0d0/
3000 cd      write(iout,*) 'In EELEC'
3001 cd      do i=1,nloctyp
3002 cd        write(iout,*) 'Type',i
3003 cd        write(iout,*) 'B1',B1(:,i)
3004 cd        write(iout,*) 'B2',B2(:,i)
3005 cd        write(iout,*) 'CC',CC(:,:,i)
3006 cd        write(iout,*) 'DD',DD(:,:,i)
3007 cd        write(iout,*) 'EE',EE(:,:,i)
3008 cd      enddo
3009 cd      call check_vecgrad
3010 cd      stop
3011       if (icheckgrad.eq.1) then
3012         do i=1,nres-1
3013           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3014           do k=1,3
3015             dc_norm(k,i)=dc(k,i)*fac
3016           enddo
3017 c          write (iout,*) 'i',i,' fac',fac
3018         enddo
3019       endif
3020       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3021      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3022      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3023 c        call vec_and_deriv
3024 #ifdef TIMING
3025         time01=MPI_Wtime()
3026 #endif
3027         call set_matrices
3028 #ifdef TIMING
3029         time_mat=time_mat+MPI_Wtime()-time01
3030 #endif
3031       endif
3032 cd      do i=1,nres-1
3033 cd        write (iout,*) 'i=',i
3034 cd        do k=1,3
3035 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3036 cd        enddo
3037 cd        do k=1,3
3038 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3039 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3040 cd        enddo
3041 cd      enddo
3042       t_eelecij=0.0d0
3043       ees=0.0D0
3044       evdw1=0.0D0
3045       eel_loc=0.0d0
3046       eello_turn3=0.0d0
3047       eello_turn4=0.0d0
3048       ind=0
3049       do i=1,nres
3050         num_cont_hb(i)=0
3051       enddo
3052 cd      print '(a)','Enter EELEC'
3053 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3054       do i=1,nres
3055         gel_loc_loc(i)=0.0d0
3056         gcorr_loc(i)=0.0d0
3057       enddo
3058 c
3059 c
3060 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3061 C
3062 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3063 C
3064 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3065       do i=iturn3_start,iturn3_end
3066         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3067      &  .or. itype(i+2).eq.ntyp1
3068      &  .or. itype(i+3).eq.ntyp1) cycle
3069         if(i.gt.1)then
3070           if(itype(i-1).eq.ntyp1)cycle
3071         end if
3072         if(i.LT.nres-3)then
3073           if (itype(i+4).eq.ntyp1) cycle
3074         end if
3075         dxi=dc(1,i)
3076         dyi=dc(2,i)
3077         dzi=dc(3,i)
3078         dx_normi=dc_norm(1,i)
3079         dy_normi=dc_norm(2,i)
3080         dz_normi=dc_norm(3,i)
3081         xmedi=c(1,i)+0.5d0*dxi
3082         ymedi=c(2,i)+0.5d0*dyi
3083         zmedi=c(3,i)+0.5d0*dzi
3084           xmedi=mod(xmedi,boxxsize)
3085           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3086           ymedi=mod(ymedi,boxysize)
3087           if (ymedi.lt.0) ymedi=ymedi+boxysize
3088           zmedi=mod(zmedi,boxzsize)
3089           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3090         num_conti=0
3091         call eelecij(i,i+2,ees,evdw1,eel_loc)
3092         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3093         num_cont_hb(i)=num_conti
3094       enddo
3095       do i=iturn4_start,iturn4_end
3096         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3097      &    .or. itype(i+3).eq.ntyp1
3098      &    .or. itype(i+4).eq.ntyp1
3099      &    .or. itype(i+5).eq.ntyp1
3100      &    .or. itype(i).eq.ntyp1
3101      &    .or. itype(i-1).eq.ntyp1
3102      &                             ) cycle
3103         dxi=dc(1,i)
3104         dyi=dc(2,i)
3105         dzi=dc(3,i)
3106         dx_normi=dc_norm(1,i)
3107         dy_normi=dc_norm(2,i)
3108         dz_normi=dc_norm(3,i)
3109         xmedi=c(1,i)+0.5d0*dxi
3110         ymedi=c(2,i)+0.5d0*dyi
3111         zmedi=c(3,i)+0.5d0*dzi
3112 C Return atom into box, boxxsize is size of box in x dimension
3113 c  194   continue
3114 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3115 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3116 C Condition for being inside the proper box
3117 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3118 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3119 c        go to 194
3120 c        endif
3121 c  195   continue
3122 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3123 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3124 C Condition for being inside the proper box
3125 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3126 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3127 c        go to 195
3128 c        endif
3129 c  196   continue
3130 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3131 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3132 C Condition for being inside the proper box
3133 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3134 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3135 c        go to 196
3136 c        endif
3137           xmedi=mod(xmedi,boxxsize)
3138           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3139           ymedi=mod(ymedi,boxysize)
3140           if (ymedi.lt.0) ymedi=ymedi+boxysize
3141           zmedi=mod(zmedi,boxzsize)
3142           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3143
3144         num_conti=num_cont_hb(i)
3145 c        write(iout,*) "JESTEM W PETLI"
3146         call eelecij(i,i+3,ees,evdw1,eel_loc)
3147         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3148      &   call eturn4(i,eello_turn4)
3149         num_cont_hb(i)=num_conti
3150       enddo   ! i
3151 C Loop over all neighbouring boxes
3152 C      do xshift=-1,1
3153 C      do yshift=-1,1
3154 C      do zshift=-1,1
3155 c
3156 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3157 c
3158       do i=iatel_s,iatel_e
3159         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3160      &  .or. itype(i+2).eq.ntyp1
3161      &  .or. itype(i-1).eq.ntyp1
3162      &                ) cycle
3163         dxi=dc(1,i)
3164         dyi=dc(2,i)
3165         dzi=dc(3,i)
3166         dx_normi=dc_norm(1,i)
3167         dy_normi=dc_norm(2,i)
3168         dz_normi=dc_norm(3,i)
3169         xmedi=c(1,i)+0.5d0*dxi
3170         ymedi=c(2,i)+0.5d0*dyi
3171         zmedi=c(3,i)+0.5d0*dzi
3172           xmedi=mod(xmedi,boxxsize)
3173           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3174           ymedi=mod(ymedi,boxysize)
3175           if (ymedi.lt.0) ymedi=ymedi+boxysize
3176           zmedi=mod(zmedi,boxzsize)
3177           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3178 C          xmedi=xmedi+xshift*boxxsize
3179 C          ymedi=ymedi+yshift*boxysize
3180 C          zmedi=zmedi+zshift*boxzsize
3181
3182 C Return tom into box, boxxsize is size of box in x dimension
3183 c  164   continue
3184 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3185 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3186 C Condition for being inside the proper box
3187 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3188 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3189 c        go to 164
3190 c        endif
3191 c  165   continue
3192 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3193 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3194 C Condition for being inside the proper box
3195 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3196 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3197 c        go to 165
3198 c        endif
3199 c  166   continue
3200 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3201 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3202 cC Condition for being inside the proper box
3203 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3204 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3205 c        go to 166
3206 c        endif
3207
3208 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3209         num_conti=num_cont_hb(i)
3210         do j=ielstart(i),ielend(i)
3211 c          write (iout,*) i,j,itype(i),itype(j)
3212           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3213      & .or.itype(j+2).eq.ntyp1
3214      & .or.itype(j-1).eq.ntyp1
3215      &) cycle
3216           call eelecij(i,j,ees,evdw1,eel_loc)
3217         enddo ! j
3218         num_cont_hb(i)=num_conti
3219       enddo   ! i
3220 C     enddo   ! zshift
3221 C      enddo   ! yshift
3222 C      enddo   ! xshift
3223
3224 c      write (iout,*) "Number of loop steps in EELEC:",ind
3225 cd      do i=1,nres
3226 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3227 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3228 cd      enddo
3229 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3230 ccc      eel_loc=eel_loc+eello_turn3
3231 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3232       return
3233       end
3234 C-------------------------------------------------------------------------------
3235       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3236       implicit real*8 (a-h,o-z)
3237       include 'DIMENSIONS'
3238 #ifdef MPI
3239       include "mpif.h"
3240 #endif
3241       include 'COMMON.CONTROL'
3242       include 'COMMON.IOUNITS'
3243       include 'COMMON.GEO'
3244       include 'COMMON.VAR'
3245       include 'COMMON.LOCAL'
3246       include 'COMMON.CHAIN'
3247       include 'COMMON.DERIV'
3248       include 'COMMON.INTERACT'
3249       include 'COMMON.CONTACTS'
3250       include 'COMMON.TORSION'
3251       include 'COMMON.VECTORS'
3252       include 'COMMON.FFIELD'
3253       include 'COMMON.TIME1'
3254       include 'COMMON.SPLITELE'
3255       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3256      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3257       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3258      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3259      &    gmuij2(4),gmuji2(4)
3260       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3261      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3262      &    num_conti,j1,j2
3263 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3264 #ifdef MOMENT
3265       double precision scal_el /1.0d0/
3266 #else
3267       double precision scal_el /0.5d0/
3268 #endif
3269 C 12/13/98
3270 C 13-go grudnia roku pamietnego...
3271       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3272      &                   0.0d0,1.0d0,0.0d0,
3273      &                   0.0d0,0.0d0,1.0d0/
3274 c          time00=MPI_Wtime()
3275 cd      write (iout,*) "eelecij",i,j
3276 c          ind=ind+1
3277           iteli=itel(i)
3278           itelj=itel(j)
3279           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3280           aaa=app(iteli,itelj)
3281           bbb=bpp(iteli,itelj)
3282           ael6i=ael6(iteli,itelj)
3283           ael3i=ael3(iteli,itelj)
3284           dxj=dc(1,j)
3285           dyj=dc(2,j)
3286           dzj=dc(3,j)
3287           dx_normj=dc_norm(1,j)
3288           dy_normj=dc_norm(2,j)
3289           dz_normj=dc_norm(3,j)
3290 C          xj=c(1,j)+0.5D0*dxj-xmedi
3291 C          yj=c(2,j)+0.5D0*dyj-ymedi
3292 C          zj=c(3,j)+0.5D0*dzj-zmedi
3293           xj=c(1,j)+0.5D0*dxj
3294           yj=c(2,j)+0.5D0*dyj
3295           zj=c(3,j)+0.5D0*dzj
3296           xj=mod(xj,boxxsize)
3297           if (xj.lt.0) xj=xj+boxxsize
3298           yj=mod(yj,boxysize)
3299           if (yj.lt.0) yj=yj+boxysize
3300           zj=mod(zj,boxzsize)
3301           if (zj.lt.0) zj=zj+boxzsize
3302           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3303       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3304       xj_safe=xj
3305       yj_safe=yj
3306       zj_safe=zj
3307       isubchap=0
3308       do xshift=-1,1
3309       do yshift=-1,1
3310       do zshift=-1,1
3311           xj=xj_safe+xshift*boxxsize
3312           yj=yj_safe+yshift*boxysize
3313           zj=zj_safe+zshift*boxzsize
3314           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3315           if(dist_temp.lt.dist_init) then
3316             dist_init=dist_temp
3317             xj_temp=xj
3318             yj_temp=yj
3319             zj_temp=zj
3320             isubchap=1
3321           endif
3322        enddo
3323        enddo
3324        enddo
3325        if (isubchap.eq.1) then
3326           xj=xj_temp-xmedi
3327           yj=yj_temp-ymedi
3328           zj=zj_temp-zmedi
3329        else
3330           xj=xj_safe-xmedi
3331           yj=yj_safe-ymedi
3332           zj=zj_safe-zmedi
3333        endif
3334 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3335 c  174   continue
3336 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3337 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3338 C Condition for being inside the proper box
3339 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3340 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3341 c        go to 174
3342 c        endif
3343 c  175   continue
3344 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3345 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3346 C Condition for being inside the proper box
3347 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3348 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3349 c        go to 175
3350 c        endif
3351 c  176   continue
3352 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3353 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3354 C Condition for being inside the proper box
3355 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3356 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3357 c        go to 176
3358 c        endif
3359 C        endif !endPBC condintion
3360 C        xj=xj-xmedi
3361 C        yj=yj-ymedi
3362 C        zj=zj-zmedi
3363           rij=xj*xj+yj*yj+zj*zj
3364
3365             sss=sscale(sqrt(rij))
3366             sssgrad=sscagrad(sqrt(rij))
3367 c            if (sss.gt.0.0d0) then
3368           rrmij=1.0D0/rij
3369           rij=dsqrt(rij)
3370           rmij=1.0D0/rij
3371           r3ij=rrmij*rmij
3372           r6ij=r3ij*r3ij
3373           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3374           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3375           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3376           fac=cosa-3.0D0*cosb*cosg
3377           ev1=aaa*r6ij*r6ij
3378 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3379           if (j.eq.i+2) ev1=scal_el*ev1
3380           ev2=bbb*r6ij
3381           fac3=ael6i*r6ij
3382           fac4=ael3i*r3ij
3383           evdwij=(ev1+ev2)
3384           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3385           el2=fac4*fac
3386 C MARYSIA
3387           eesij=(el1+el2)
3388 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3389           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3390           ees=ees+eesij
3391           evdw1=evdw1+evdwij*sss
3392 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3393 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3394 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3395 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3396
3397           if (energy_dec) then
3398               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3399      &'evdw1',i,j,evdwij
3400      &,iteli,itelj,aaa,evdw1
3401               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3402           endif
3403
3404 C
3405 C Calculate contributions to the Cartesian gradient.
3406 C
3407 #ifdef SPLITELE
3408           facvdw=-6*rrmij*(ev1+evdwij)*sss
3409           facel=-3*rrmij*(el1+eesij)
3410           fac1=fac
3411           erij(1)=xj*rmij
3412           erij(2)=yj*rmij
3413           erij(3)=zj*rmij
3414 *
3415 * Radial derivatives. First process both termini of the fragment (i,j)
3416 *
3417           ggg(1)=facel*xj
3418           ggg(2)=facel*yj
3419           ggg(3)=facel*zj
3420 c          do k=1,3
3421 c            ghalf=0.5D0*ggg(k)
3422 c            gelc(k,i)=gelc(k,i)+ghalf
3423 c            gelc(k,j)=gelc(k,j)+ghalf
3424 c          enddo
3425 c 9/28/08 AL Gradient compotents will be summed only at the end
3426           do k=1,3
3427             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3428             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3429           enddo
3430 *
3431 * Loop over residues i+1 thru j-1.
3432 *
3433 cgrad          do k=i+1,j-1
3434 cgrad            do l=1,3
3435 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3436 cgrad            enddo
3437 cgrad          enddo
3438           if (sss.gt.0.0) then
3439           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3440           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3441           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3442           else
3443           ggg(1)=0.0
3444           ggg(2)=0.0
3445           ggg(3)=0.0
3446           endif
3447 c          do k=1,3
3448 c            ghalf=0.5D0*ggg(k)
3449 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3450 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3451 c          enddo
3452 c 9/28/08 AL Gradient compotents will be summed only at the end
3453           do k=1,3
3454             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3455             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3456           enddo
3457 *
3458 * Loop over residues i+1 thru j-1.
3459 *
3460 cgrad          do k=i+1,j-1
3461 cgrad            do l=1,3
3462 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3463 cgrad            enddo
3464 cgrad          enddo
3465 #else
3466 C MARYSIA
3467           facvdw=(ev1+evdwij)*sss
3468           facel=(el1+eesij)
3469           fac1=fac
3470           fac=-3*rrmij*(facvdw+facvdw+facel)
3471           erij(1)=xj*rmij
3472           erij(2)=yj*rmij
3473           erij(3)=zj*rmij
3474 *
3475 * Radial derivatives. First process both termini of the fragment (i,j)
3476 *
3477           ggg(1)=fac*xj
3478           ggg(2)=fac*yj
3479           ggg(3)=fac*zj
3480 c          do k=1,3
3481 c            ghalf=0.5D0*ggg(k)
3482 c            gelc(k,i)=gelc(k,i)+ghalf
3483 c            gelc(k,j)=gelc(k,j)+ghalf
3484 c          enddo
3485 c 9/28/08 AL Gradient compotents will be summed only at the end
3486           do k=1,3
3487             gelc_long(k,j)=gelc(k,j)+ggg(k)
3488             gelc_long(k,i)=gelc(k,i)-ggg(k)
3489           enddo
3490 *
3491 * Loop over residues i+1 thru j-1.
3492 *
3493 cgrad          do k=i+1,j-1
3494 cgrad            do l=1,3
3495 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3496 cgrad            enddo
3497 cgrad          enddo
3498 c 9/28/08 AL Gradient compotents will be summed only at the end
3499           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3500           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3501           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3502           do k=1,3
3503             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3504             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3505           enddo
3506 #endif
3507 *
3508 * Angular part
3509 *
3510           ecosa=2.0D0*fac3*fac1+fac4
3511           fac4=-3.0D0*fac4
3512           fac3=-6.0D0*fac3
3513           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3514           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3515           do k=1,3
3516             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3517             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3518           enddo
3519 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3520 cd   &          (dcosg(k),k=1,3)
3521           do k=1,3
3522             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3523           enddo
3524 c          do k=1,3
3525 c            ghalf=0.5D0*ggg(k)
3526 c            gelc(k,i)=gelc(k,i)+ghalf
3527 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3528 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3529 c            gelc(k,j)=gelc(k,j)+ghalf
3530 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3531 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3532 c          enddo
3533 cgrad          do k=i+1,j-1
3534 cgrad            do l=1,3
3535 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3536 cgrad            enddo
3537 cgrad          enddo
3538           do k=1,3
3539             gelc(k,i)=gelc(k,i)
3540      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3541      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3542             gelc(k,j)=gelc(k,j)
3543      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3544      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3545             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3546             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3547           enddo
3548 C MARYSIA
3549 c          endif !sscale
3550           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3551      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3552      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3553 C
3554 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3555 C   energy of a peptide unit is assumed in the form of a second-order
3556 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3557 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3558 C   are computed for EVERY pair of non-contiguous peptide groups.
3559 C
3560
3561           if (j.lt.nres-1) then
3562             j1=j+1
3563             j2=j-1
3564           else
3565             j1=j-1
3566             j2=j-2
3567           endif
3568           kkk=0
3569           lll=0
3570           do k=1,2
3571             do l=1,2
3572               kkk=kkk+1
3573               muij(kkk)=mu(k,i)*mu(l,j)
3574 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3575 #ifdef NEWCORR
3576              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3577 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3578              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3579              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3580 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3581              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3582 #endif
3583             enddo
3584           enddo
3585 cd         write (iout,*) 'EELEC: i',i,' j',j
3586 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3587 cd          write(iout,*) 'muij',muij
3588           ury=scalar(uy(1,i),erij)
3589           urz=scalar(uz(1,i),erij)
3590           vry=scalar(uy(1,j),erij)
3591           vrz=scalar(uz(1,j),erij)
3592           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3593           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3594           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3595           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3596           fac=dsqrt(-ael6i)*r3ij
3597           a22=a22*fac
3598           a23=a23*fac
3599           a32=a32*fac
3600           a33=a33*fac
3601 cd          write (iout,'(4i5,4f10.5)')
3602 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3603 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3604 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3605 cd     &      uy(:,j),uz(:,j)
3606 cd          write (iout,'(4f10.5)')
3607 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3608 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3609 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3610 cd           write (iout,'(9f10.5/)')
3611 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3612 C Derivatives of the elements of A in virtual-bond vectors
3613           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3614           do k=1,3
3615             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3616             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3617             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3618             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3619             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3620             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3621             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3622             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3623             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3624             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3625             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3626             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3627           enddo
3628 C Compute radial contributions to the gradient
3629           facr=-3.0d0*rrmij
3630           a22der=a22*facr
3631           a23der=a23*facr
3632           a32der=a32*facr
3633           a33der=a33*facr
3634           agg(1,1)=a22der*xj
3635           agg(2,1)=a22der*yj
3636           agg(3,1)=a22der*zj
3637           agg(1,2)=a23der*xj
3638           agg(2,2)=a23der*yj
3639           agg(3,2)=a23der*zj
3640           agg(1,3)=a32der*xj
3641           agg(2,3)=a32der*yj
3642           agg(3,3)=a32der*zj
3643           agg(1,4)=a33der*xj
3644           agg(2,4)=a33der*yj
3645           agg(3,4)=a33der*zj
3646 C Add the contributions coming from er
3647           fac3=-3.0d0*fac
3648           do k=1,3
3649             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3650             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3651             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3652             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3653           enddo
3654           do k=1,3
3655 C Derivatives in DC(i)
3656 cgrad            ghalf1=0.5d0*agg(k,1)
3657 cgrad            ghalf2=0.5d0*agg(k,2)
3658 cgrad            ghalf3=0.5d0*agg(k,3)
3659 cgrad            ghalf4=0.5d0*agg(k,4)
3660             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3661      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3662             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3663      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3664             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3665      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3666             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3667      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3668 C Derivatives in DC(i+1)
3669             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3670      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3671             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3672      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3673             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3674      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3675             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3676      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3677 C Derivatives in DC(j)
3678             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3679      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3680             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3681      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3682             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3683      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3684             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3685      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3686 C Derivatives in DC(j+1) or DC(nres-1)
3687             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3688      &      -3.0d0*vryg(k,3)*ury)
3689             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3690      &      -3.0d0*vrzg(k,3)*ury)
3691             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3692      &      -3.0d0*vryg(k,3)*urz)
3693             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3694      &      -3.0d0*vrzg(k,3)*urz)
3695 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3696 cgrad              do l=1,4
3697 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3698 cgrad              enddo
3699 cgrad            endif
3700           enddo
3701           acipa(1,1)=a22
3702           acipa(1,2)=a23
3703           acipa(2,1)=a32
3704           acipa(2,2)=a33
3705           a22=-a22
3706           a23=-a23
3707           do l=1,2
3708             do k=1,3
3709               agg(k,l)=-agg(k,l)
3710               aggi(k,l)=-aggi(k,l)
3711               aggi1(k,l)=-aggi1(k,l)
3712               aggj(k,l)=-aggj(k,l)
3713               aggj1(k,l)=-aggj1(k,l)
3714             enddo
3715           enddo
3716           if (j.lt.nres-1) then
3717             a22=-a22
3718             a32=-a32
3719             do l=1,3,2
3720               do k=1,3
3721                 agg(k,l)=-agg(k,l)
3722                 aggi(k,l)=-aggi(k,l)
3723                 aggi1(k,l)=-aggi1(k,l)
3724                 aggj(k,l)=-aggj(k,l)
3725                 aggj1(k,l)=-aggj1(k,l)
3726               enddo
3727             enddo
3728           else
3729             a22=-a22
3730             a23=-a23
3731             a32=-a32
3732             a33=-a33
3733             do l=1,4
3734               do k=1,3
3735                 agg(k,l)=-agg(k,l)
3736                 aggi(k,l)=-aggi(k,l)
3737                 aggi1(k,l)=-aggi1(k,l)
3738                 aggj(k,l)=-aggj(k,l)
3739                 aggj1(k,l)=-aggj1(k,l)
3740               enddo
3741             enddo
3742           endif
3743           ENDIF ! WCORR
3744           IF (wel_loc.gt.0.0d0) THEN
3745 C Contribution to the local-electrostatic energy coming from the i-j pair
3746           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3747      &     +a33*muij(4)
3748 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3749 c     &                     ' eel_loc_ij',eel_loc_ij
3750 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3751 C Calculate patrial derivative for theta angle
3752 #ifdef NEWCORR
3753          geel_loc_ij=a22*gmuij1(1)
3754      &     +a23*gmuij1(2)
3755      &     +a32*gmuij1(3)
3756      &     +a33*gmuij1(4)
3757 c         write(iout,*) "derivative over thatai"
3758 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3759 c     &   a33*gmuij1(4)
3760          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3761      &      geel_loc_ij*wel_loc
3762 c         write(iout,*) "derivative over thatai-1"
3763 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3764 c     &   a33*gmuij2(4)
3765          geel_loc_ij=
3766      &     a22*gmuij2(1)
3767      &     +a23*gmuij2(2)
3768      &     +a32*gmuij2(3)
3769      &     +a33*gmuij2(4)
3770          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3771      &      geel_loc_ij*wel_loc
3772 c  Derivative over j residue
3773          geel_loc_ji=a22*gmuji1(1)
3774      &     +a23*gmuji1(2)
3775      &     +a32*gmuji1(3)
3776      &     +a33*gmuji1(4)
3777 c         write(iout,*) "derivative over thataj"
3778 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3779 c     &   a33*gmuji1(4)
3780
3781         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3782      &      geel_loc_ji*wel_loc
3783          geel_loc_ji=
3784      &     +a22*gmuji2(1)
3785      &     +a23*gmuji2(2)
3786      &     +a32*gmuji2(3)
3787      &     +a33*gmuji2(4)
3788 c         write(iout,*) "derivative over thataj-1"
3789 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3790 c     &   a33*gmuji2(4)
3791          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3792      &      geel_loc_ji*wel_loc
3793 #endif
3794 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3795
3796           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3797      &            'eelloc',i,j,eel_loc_ij
3798 c           if (eel_loc_ij.ne.0)
3799 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3800 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3801
3802           eel_loc=eel_loc+eel_loc_ij
3803 C Partial derivatives in virtual-bond dihedral angles gamma
3804           if (i.gt.1)
3805      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3806      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3807      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3808           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3809      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3810      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3811 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3812           do l=1,3
3813             ggg(l)=agg(l,1)*muij(1)+
3814      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3815             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3816             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3817 cgrad            ghalf=0.5d0*ggg(l)
3818 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3819 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3820           enddo
3821 cgrad          do k=i+1,j2
3822 cgrad            do l=1,3
3823 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3824 cgrad            enddo
3825 cgrad          enddo
3826 C Remaining derivatives of eello
3827           do l=1,3
3828             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3829      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3830             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3831      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3832             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3833      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3834             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3835      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3836           enddo
3837           ENDIF
3838 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3839 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3840           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3841      &       .and. num_conti.le.maxconts) then
3842 c            write (iout,*) i,j," entered corr"
3843 C
3844 C Calculate the contact function. The ith column of the array JCONT will
3845 C contain the numbers of atoms that make contacts with the atom I (of numbers
3846 C greater than I). The arrays FACONT and GACONT will contain the values of
3847 C the contact function and its derivative.
3848 c           r0ij=1.02D0*rpp(iteli,itelj)
3849 c           r0ij=1.11D0*rpp(iteli,itelj)
3850             r0ij=2.20D0*rpp(iteli,itelj)
3851 c           r0ij=1.55D0*rpp(iteli,itelj)
3852             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3853             if (fcont.gt.0.0D0) then
3854               num_conti=num_conti+1
3855               if (num_conti.gt.maxconts) then
3856                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3857      &                         ' will skip next contacts for this conf.'
3858               else
3859                 jcont_hb(num_conti,i)=j
3860 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3861 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3862                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3863      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3864 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3865 C  terms.
3866                 d_cont(num_conti,i)=rij
3867 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3868 C     --- Electrostatic-interaction matrix ---
3869                 a_chuj(1,1,num_conti,i)=a22
3870                 a_chuj(1,2,num_conti,i)=a23
3871                 a_chuj(2,1,num_conti,i)=a32
3872                 a_chuj(2,2,num_conti,i)=a33
3873 C     --- Gradient of rij
3874                 do kkk=1,3
3875                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3876                 enddo
3877                 kkll=0
3878                 do k=1,2
3879                   do l=1,2
3880                     kkll=kkll+1
3881                     do m=1,3
3882                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3883                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3884                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3885                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3886                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3887                     enddo
3888                   enddo
3889                 enddo
3890                 ENDIF
3891                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3892 C Calculate contact energies
3893                 cosa4=4.0D0*cosa
3894                 wij=cosa-3.0D0*cosb*cosg
3895                 cosbg1=cosb+cosg
3896                 cosbg2=cosb-cosg
3897 c               fac3=dsqrt(-ael6i)/r0ij**3
3898                 fac3=dsqrt(-ael6i)*r3ij
3899 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3900                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3901                 if (ees0tmp.gt.0) then
3902                   ees0pij=dsqrt(ees0tmp)
3903                 else
3904                   ees0pij=0
3905                 endif
3906 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3907                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3908                 if (ees0tmp.gt.0) then
3909                   ees0mij=dsqrt(ees0tmp)
3910                 else
3911                   ees0mij=0
3912                 endif
3913 c               ees0mij=0.0D0
3914                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3915                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3916 C Diagnostics. Comment out or remove after debugging!
3917 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3918 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3919 c               ees0m(num_conti,i)=0.0D0
3920 C End diagnostics.
3921 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3922 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3923 C Angular derivatives of the contact function
3924                 ees0pij1=fac3/ees0pij
3925                 ees0mij1=fac3/ees0mij
3926                 fac3p=-3.0D0*fac3*rrmij
3927                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3928                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3929 c               ees0mij1=0.0D0
3930                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3931                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3932                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3933                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3934                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3935                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3936                 ecosap=ecosa1+ecosa2
3937                 ecosbp=ecosb1+ecosb2
3938                 ecosgp=ecosg1+ecosg2
3939                 ecosam=ecosa1-ecosa2
3940                 ecosbm=ecosb1-ecosb2
3941                 ecosgm=ecosg1-ecosg2
3942 C Diagnostics
3943 c               ecosap=ecosa1
3944 c               ecosbp=ecosb1
3945 c               ecosgp=ecosg1
3946 c               ecosam=0.0D0
3947 c               ecosbm=0.0D0
3948 c               ecosgm=0.0D0
3949 C End diagnostics
3950                 facont_hb(num_conti,i)=fcont
3951                 fprimcont=fprimcont/rij
3952 cd              facont_hb(num_conti,i)=1.0D0
3953 C Following line is for diagnostics.
3954 cd              fprimcont=0.0D0
3955                 do k=1,3
3956                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3957                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3958                 enddo
3959                 do k=1,3
3960                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3961                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3962                 enddo
3963                 gggp(1)=gggp(1)+ees0pijp*xj
3964                 gggp(2)=gggp(2)+ees0pijp*yj
3965                 gggp(3)=gggp(3)+ees0pijp*zj
3966                 gggm(1)=gggm(1)+ees0mijp*xj
3967                 gggm(2)=gggm(2)+ees0mijp*yj
3968                 gggm(3)=gggm(3)+ees0mijp*zj
3969 C Derivatives due to the contact function
3970                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3971                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3972                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3973                 do k=1,3
3974 c
3975 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3976 c          following the change of gradient-summation algorithm.
3977 c
3978 cgrad                  ghalfp=0.5D0*gggp(k)
3979 cgrad                  ghalfm=0.5D0*gggm(k)
3980                   gacontp_hb1(k,num_conti,i)=!ghalfp
3981      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3982      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3983                   gacontp_hb2(k,num_conti,i)=!ghalfp
3984      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3985      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3986                   gacontp_hb3(k,num_conti,i)=gggp(k)
3987                   gacontm_hb1(k,num_conti,i)=!ghalfm
3988      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3989      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3990                   gacontm_hb2(k,num_conti,i)=!ghalfm
3991      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3992      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3993                   gacontm_hb3(k,num_conti,i)=gggm(k)
3994                 enddo
3995 C Diagnostics. Comment out or remove after debugging!
3996 cdiag           do k=1,3
3997 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3998 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3999 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4000 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4001 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4002 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4003 cdiag           enddo
4004               ENDIF ! wcorr
4005               endif  ! num_conti.le.maxconts
4006             endif  ! fcont.gt.0
4007           endif    ! j.gt.i+1
4008           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4009             do k=1,4
4010               do l=1,3
4011                 ghalf=0.5d0*agg(l,k)
4012                 aggi(l,k)=aggi(l,k)+ghalf
4013                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4014                 aggj(l,k)=aggj(l,k)+ghalf
4015               enddo
4016             enddo
4017             if (j.eq.nres-1 .and. i.lt.j-2) then
4018               do k=1,4
4019                 do l=1,3
4020                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4021                 enddo
4022               enddo
4023             endif
4024           endif
4025 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4026       return
4027       end
4028 C-----------------------------------------------------------------------------
4029       subroutine eturn3(i,eello_turn3)
4030 C Third- and fourth-order contributions from turns
4031       implicit real*8 (a-h,o-z)
4032       include 'DIMENSIONS'
4033       include 'COMMON.IOUNITS'
4034       include 'COMMON.GEO'
4035       include 'COMMON.VAR'
4036       include 'COMMON.LOCAL'
4037       include 'COMMON.CHAIN'
4038       include 'COMMON.DERIV'
4039       include 'COMMON.INTERACT'
4040       include 'COMMON.CONTACTS'
4041       include 'COMMON.TORSION'
4042       include 'COMMON.VECTORS'
4043       include 'COMMON.FFIELD'
4044       include 'COMMON.CONTROL'
4045       dimension ggg(3)
4046       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4047      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4048      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4049      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4050      &  auxgmat2(2,2),auxgmatt2(2,2)
4051       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4052      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4053       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4054      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4055      &    num_conti,j1,j2
4056       j=i+2
4057 c      write (iout,*) "eturn3",i,j,j1,j2
4058       a_temp(1,1)=a22
4059       a_temp(1,2)=a23
4060       a_temp(2,1)=a32
4061       a_temp(2,2)=a33
4062 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4063 C
4064 C               Third-order contributions
4065 C
4066 C                 (i+2)o----(i+3)
4067 C                      | |
4068 C                      | |
4069 C                 (i+1)o----i
4070 C
4071 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4072 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4073         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4074 c auxalary matices for theta gradient
4075 c auxalary matrix for i+1 and constant i+2
4076         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4077 c auxalary matrix for i+2 and constant i+1
4078         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4079         call transpose2(auxmat(1,1),auxmat1(1,1))
4080         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4081         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4082         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4083         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4084         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4085         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4086 C Derivatives in theta
4087         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4088      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4089         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4090      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4091
4092         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4093      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4094 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4095 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4096 cd     &    ' eello_turn3_num',4*eello_turn3_num
4097 C Derivatives in gamma(i)
4098         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4099         call transpose2(auxmat2(1,1),auxmat3(1,1))
4100         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4101         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4102 C Derivatives in gamma(i+1)
4103         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4104         call transpose2(auxmat2(1,1),auxmat3(1,1))
4105         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4106         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4107      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4108 C Cartesian derivatives
4109         do l=1,3
4110 c            ghalf1=0.5d0*agg(l,1)
4111 c            ghalf2=0.5d0*agg(l,2)
4112 c            ghalf3=0.5d0*agg(l,3)
4113 c            ghalf4=0.5d0*agg(l,4)
4114           a_temp(1,1)=aggi(l,1)!+ghalf1
4115           a_temp(1,2)=aggi(l,2)!+ghalf2
4116           a_temp(2,1)=aggi(l,3)!+ghalf3
4117           a_temp(2,2)=aggi(l,4)!+ghalf4
4118           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4119           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4120      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4121           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4122           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4123           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4124           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4125           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4126           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4127      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4128           a_temp(1,1)=aggj(l,1)!+ghalf1
4129           a_temp(1,2)=aggj(l,2)!+ghalf2
4130           a_temp(2,1)=aggj(l,3)!+ghalf3
4131           a_temp(2,2)=aggj(l,4)!+ghalf4
4132           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4133           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4134      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4135           a_temp(1,1)=aggj1(l,1)
4136           a_temp(1,2)=aggj1(l,2)
4137           a_temp(2,1)=aggj1(l,3)
4138           a_temp(2,2)=aggj1(l,4)
4139           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4140           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4141      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4142         enddo
4143       return
4144       end
4145 C-------------------------------------------------------------------------------
4146       subroutine eturn4(i,eello_turn4)
4147 C Third- and fourth-order contributions from turns
4148       implicit real*8 (a-h,o-z)
4149       include 'DIMENSIONS'
4150       include 'COMMON.IOUNITS'
4151       include 'COMMON.GEO'
4152       include 'COMMON.VAR'
4153       include 'COMMON.LOCAL'
4154       include 'COMMON.CHAIN'
4155       include 'COMMON.DERIV'
4156       include 'COMMON.INTERACT'
4157       include 'COMMON.CONTACTS'
4158       include 'COMMON.TORSION'
4159       include 'COMMON.VECTORS'
4160       include 'COMMON.FFIELD'
4161       include 'COMMON.CONTROL'
4162       dimension ggg(3)
4163       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4164      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4165      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4166      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4167      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4168      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4169      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4170       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4171      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4172       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4173      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4174      &    num_conti,j1,j2
4175       j=i+3
4176 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4177 C
4178 C               Fourth-order contributions
4179 C
4180 C                 (i+3)o----(i+4)
4181 C                     /  |
4182 C               (i+2)o   |
4183 C                     \  |
4184 C                 (i+1)o----i
4185 C
4186 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4187 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4188 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4189 c        write(iout,*)"WCHODZE W PROGRAM"
4190         a_temp(1,1)=a22
4191         a_temp(1,2)=a23
4192         a_temp(2,1)=a32
4193         a_temp(2,2)=a33
4194         iti1=itortyp(itype(i+1))
4195         iti2=itortyp(itype(i+2))
4196         iti3=itortyp(itype(i+3))
4197 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4198         call transpose2(EUg(1,1,i+1),e1t(1,1))
4199         call transpose2(Eug(1,1,i+2),e2t(1,1))
4200         call transpose2(Eug(1,1,i+3),e3t(1,1))
4201 C Ematrix derivative in theta
4202         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4203         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4204         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4205         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4206 c       eta1 in derivative theta
4207         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4208         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4209 c       auxgvec is derivative of Ub2 so i+3 theta
4210         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4211 c       auxalary matrix of E i+1
4212         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4213 c        s1=0.0
4214 c        gs1=0.0
4215         s1=scalar2(b1(1,i+2),auxvec(1))
4216 c derivative of theta i+2 with constant i+3
4217         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4218 c derivative of theta i+2 with constant i+2
4219         gs32=scalar2(b1(1,i+2),auxgvec(1))
4220 c derivative of E matix in theta of i+1
4221         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4222
4223         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4224 c       ea31 in derivative theta
4225         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4226         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4227 c auxilary matrix auxgvec of Ub2 with constant E matirx
4228         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4229 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4230         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4231
4232 c        s2=0.0
4233 c        gs2=0.0
4234         s2=scalar2(b1(1,i+1),auxvec(1))
4235 c derivative of theta i+1 with constant i+3
4236         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4237 c derivative of theta i+2 with constant i+1
4238         gs21=scalar2(b1(1,i+1),auxgvec(1))
4239 c derivative of theta i+3 with constant i+1
4240         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4241 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4242 c     &  gtb1(1,i+1)
4243         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4244 c two derivatives over diffetent matrices
4245 c gtae3e2 is derivative over i+3
4246         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4247 c ae3gte2 is derivative over i+2
4248         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4249         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4250 c three possible derivative over theta E matices
4251 c i+1
4252         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4253 c i+2
4254         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4255 c i+3
4256         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4257         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4258
4259         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4260         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4261         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4262
4263         eello_turn4=eello_turn4-(s1+s2+s3)
4264 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4265         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4266      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4267 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4268 cd     &    ' eello_turn4_num',8*eello_turn4_num
4269 #ifdef NEWCORR
4270         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4271      &                  -(gs13+gsE13+gsEE1)*wturn4
4272         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4273      &                    -(gs23+gs21+gsEE2)*wturn4
4274         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4275      &                    -(gs32+gsE31+gsEE3)*wturn4
4276 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4277 c     &   gs2
4278 #endif
4279         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4280      &      'eturn4',i,j,-(s1+s2+s3)
4281 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4282 c     &    ' eello_turn4_num',8*eello_turn4_num
4283 C Derivatives in gamma(i)
4284         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4285         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4286         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4287         s1=scalar2(b1(1,i+2),auxvec(1))
4288         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4289         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4290         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4291 C Derivatives in gamma(i+1)
4292         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4293         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4294         s2=scalar2(b1(1,i+1),auxvec(1))
4295         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4296         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4297         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4298         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4299 C Derivatives in gamma(i+2)
4300         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4301         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4302         s1=scalar2(b1(1,i+2),auxvec(1))
4303         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4304         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4305         s2=scalar2(b1(1,i+1),auxvec(1))
4306         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4307         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4308         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4309         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4310 C Cartesian derivatives
4311 C Derivatives of this turn contributions in DC(i+2)
4312         if (j.lt.nres-1) then
4313           do l=1,3
4314             a_temp(1,1)=agg(l,1)
4315             a_temp(1,2)=agg(l,2)
4316             a_temp(2,1)=agg(l,3)
4317             a_temp(2,2)=agg(l,4)
4318             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4319             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4320             s1=scalar2(b1(1,i+2),auxvec(1))
4321             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4322             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4323             s2=scalar2(b1(1,i+1),auxvec(1))
4324             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4325             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4326             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4327             ggg(l)=-(s1+s2+s3)
4328             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4329           enddo
4330         endif
4331 C Remaining derivatives of this turn contribution
4332         do l=1,3
4333           a_temp(1,1)=aggi(l,1)
4334           a_temp(1,2)=aggi(l,2)
4335           a_temp(2,1)=aggi(l,3)
4336           a_temp(2,2)=aggi(l,4)
4337           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4338           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4339           s1=scalar2(b1(1,i+2),auxvec(1))
4340           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4341           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4342           s2=scalar2(b1(1,i+1),auxvec(1))
4343           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4344           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4345           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4346           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4347           a_temp(1,1)=aggi1(l,1)
4348           a_temp(1,2)=aggi1(l,2)
4349           a_temp(2,1)=aggi1(l,3)
4350           a_temp(2,2)=aggi1(l,4)
4351           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4352           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4353           s1=scalar2(b1(1,i+2),auxvec(1))
4354           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4355           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4356           s2=scalar2(b1(1,i+1),auxvec(1))
4357           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4358           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4359           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4360           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4361           a_temp(1,1)=aggj(l,1)
4362           a_temp(1,2)=aggj(l,2)
4363           a_temp(2,1)=aggj(l,3)
4364           a_temp(2,2)=aggj(l,4)
4365           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4366           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4367           s1=scalar2(b1(1,i+2),auxvec(1))
4368           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4369           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4370           s2=scalar2(b1(1,i+1),auxvec(1))
4371           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4372           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4373           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4374           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4375           a_temp(1,1)=aggj1(l,1)
4376           a_temp(1,2)=aggj1(l,2)
4377           a_temp(2,1)=aggj1(l,3)
4378           a_temp(2,2)=aggj1(l,4)
4379           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4380           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4381           s1=scalar2(b1(1,i+2),auxvec(1))
4382           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4383           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4384           s2=scalar2(b1(1,i+1),auxvec(1))
4385           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4386           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4387           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4388 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4389           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4390         enddo
4391       return
4392       end
4393 C-----------------------------------------------------------------------------
4394       subroutine vecpr(u,v,w)
4395       implicit real*8(a-h,o-z)
4396       dimension u(3),v(3),w(3)
4397       w(1)=u(2)*v(3)-u(3)*v(2)
4398       w(2)=-u(1)*v(3)+u(3)*v(1)
4399       w(3)=u(1)*v(2)-u(2)*v(1)
4400       return
4401       end
4402 C-----------------------------------------------------------------------------
4403       subroutine unormderiv(u,ugrad,unorm,ungrad)
4404 C This subroutine computes the derivatives of a normalized vector u, given
4405 C the derivatives computed without normalization conditions, ugrad. Returns
4406 C ungrad.
4407       implicit none
4408       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4409       double precision vec(3)
4410       double precision scalar
4411       integer i,j
4412 c      write (2,*) 'ugrad',ugrad
4413 c      write (2,*) 'u',u
4414       do i=1,3
4415         vec(i)=scalar(ugrad(1,i),u(1))
4416       enddo
4417 c      write (2,*) 'vec',vec
4418       do i=1,3
4419         do j=1,3
4420           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4421         enddo
4422       enddo
4423 c      write (2,*) 'ungrad',ungrad
4424       return
4425       end
4426 C-----------------------------------------------------------------------------
4427       subroutine escp_soft_sphere(evdw2,evdw2_14)
4428 C
4429 C This subroutine calculates the excluded-volume interaction energy between
4430 C peptide-group centers and side chains and its gradient in virtual-bond and
4431 C side-chain vectors.
4432 C
4433       implicit real*8 (a-h,o-z)
4434       include 'DIMENSIONS'
4435       include 'COMMON.GEO'
4436       include 'COMMON.VAR'
4437       include 'COMMON.LOCAL'
4438       include 'COMMON.CHAIN'
4439       include 'COMMON.DERIV'
4440       include 'COMMON.INTERACT'
4441       include 'COMMON.FFIELD'
4442       include 'COMMON.IOUNITS'
4443       include 'COMMON.CONTROL'
4444       dimension ggg(3)
4445       evdw2=0.0D0
4446       evdw2_14=0.0d0
4447       r0_scp=4.5d0
4448 cd    print '(a)','Enter ESCP'
4449 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4450 C      do xshift=-1,1
4451 C      do yshift=-1,1
4452 C      do zshift=-1,1
4453       do i=iatscp_s,iatscp_e
4454         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4455         iteli=itel(i)
4456         xi=0.5D0*(c(1,i)+c(1,i+1))
4457         yi=0.5D0*(c(2,i)+c(2,i+1))
4458         zi=0.5D0*(c(3,i)+c(3,i+1))
4459 C Return atom into box, boxxsize is size of box in x dimension
4460 c  134   continue
4461 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4462 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4463 C Condition for being inside the proper box
4464 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4465 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4466 c        go to 134
4467 c        endif
4468 c  135   continue
4469 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4470 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4471 C Condition for being inside the proper box
4472 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4473 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4474 c        go to 135
4475 c c       endif
4476 c  136   continue
4477 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4478 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4479 cC Condition for being inside the proper box
4480 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4481 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4482 c        go to 136
4483 c        endif
4484           xi=mod(xi,boxxsize)
4485           if (xi.lt.0) xi=xi+boxxsize
4486           yi=mod(yi,boxysize)
4487           if (yi.lt.0) yi=yi+boxysize
4488           zi=mod(zi,boxzsize)
4489           if (zi.lt.0) zi=zi+boxzsize
4490 C          xi=xi+xshift*boxxsize
4491 C          yi=yi+yshift*boxysize
4492 C          zi=zi+zshift*boxzsize
4493         do iint=1,nscp_gr(i)
4494
4495         do j=iscpstart(i,iint),iscpend(i,iint)
4496           if (itype(j).eq.ntyp1) cycle
4497           itypj=iabs(itype(j))
4498 C Uncomment following three lines for SC-p interactions
4499 c         xj=c(1,nres+j)-xi
4500 c         yj=c(2,nres+j)-yi
4501 c         zj=c(3,nres+j)-zi
4502 C Uncomment following three lines for Ca-p interactions
4503           xj=c(1,j)
4504           yj=c(2,j)
4505           zj=c(3,j)
4506 c  174   continue
4507 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4508 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4509 C Condition for being inside the proper box
4510 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4511 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4512 c        go to 174
4513 c        endif
4514 c  175   continue
4515 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4516 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4517 cC Condition for being inside the proper box
4518 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4519 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4520 c        go to 175
4521 c        endif
4522 c  176   continue
4523 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4524 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4525 C Condition for being inside the proper box
4526 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4527 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4528 c        go to 176
4529           xj=mod(xj,boxxsize)
4530           if (xj.lt.0) xj=xj+boxxsize
4531           yj=mod(yj,boxysize)
4532           if (yj.lt.0) yj=yj+boxysize
4533           zj=mod(zj,boxzsize)
4534           if (zj.lt.0) zj=zj+boxzsize
4535       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4536       xj_safe=xj
4537       yj_safe=yj
4538       zj_safe=zj
4539       subchap=0
4540       do xshift=-1,1
4541       do yshift=-1,1
4542       do zshift=-1,1
4543           xj=xj_safe+xshift*boxxsize
4544           yj=yj_safe+yshift*boxysize
4545           zj=zj_safe+zshift*boxzsize
4546           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4547           if(dist_temp.lt.dist_init) then
4548             dist_init=dist_temp
4549             xj_temp=xj
4550             yj_temp=yj
4551             zj_temp=zj
4552             subchap=1
4553           endif
4554        enddo
4555        enddo
4556        enddo
4557        if (subchap.eq.1) then
4558           xj=xj_temp-xi
4559           yj=yj_temp-yi
4560           zj=zj_temp-zi
4561        else
4562           xj=xj_safe-xi
4563           yj=yj_safe-yi
4564           zj=zj_safe-zi
4565        endif
4566 c c       endif
4567 C          xj=xj-xi
4568 C          yj=yj-yi
4569 C          zj=zj-zi
4570           rij=xj*xj+yj*yj+zj*zj
4571
4572           r0ij=r0_scp
4573           r0ijsq=r0ij*r0ij
4574           if (rij.lt.r0ijsq) then
4575             evdwij=0.25d0*(rij-r0ijsq)**2
4576             fac=rij-r0ijsq
4577           else
4578             evdwij=0.0d0
4579             fac=0.0d0
4580           endif
4581           evdw2=evdw2+evdwij
4582 C
4583 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4584 C
4585           ggg(1)=xj*fac
4586           ggg(2)=yj*fac
4587           ggg(3)=zj*fac
4588 cgrad          if (j.lt.i) then
4589 cd          write (iout,*) 'j<i'
4590 C Uncomment following three lines for SC-p interactions
4591 c           do k=1,3
4592 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4593 c           enddo
4594 cgrad          else
4595 cd          write (iout,*) 'j>i'
4596 cgrad            do k=1,3
4597 cgrad              ggg(k)=-ggg(k)
4598 C Uncomment following line for SC-p interactions
4599 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4600 cgrad            enddo
4601 cgrad          endif
4602 cgrad          do k=1,3
4603 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4604 cgrad          enddo
4605 cgrad          kstart=min0(i+1,j)
4606 cgrad          kend=max0(i-1,j-1)
4607 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4608 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4609 cgrad          do k=kstart,kend
4610 cgrad            do l=1,3
4611 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4612 cgrad            enddo
4613 cgrad          enddo
4614           do k=1,3
4615             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4616             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4617           enddo
4618         enddo
4619
4620         enddo ! iint
4621       enddo ! i
4622 C      enddo !zshift
4623 C      enddo !yshift
4624 C      enddo !xshift
4625       return
4626       end
4627 C-----------------------------------------------------------------------------
4628       subroutine escp(evdw2,evdw2_14)
4629 C
4630 C This subroutine calculates the excluded-volume interaction energy between
4631 C peptide-group centers and side chains and its gradient in virtual-bond and
4632 C side-chain vectors.
4633 C
4634       implicit real*8 (a-h,o-z)
4635       include 'DIMENSIONS'
4636       include 'COMMON.GEO'
4637       include 'COMMON.VAR'
4638       include 'COMMON.LOCAL'
4639       include 'COMMON.CHAIN'
4640       include 'COMMON.DERIV'
4641       include 'COMMON.INTERACT'
4642       include 'COMMON.FFIELD'
4643       include 'COMMON.IOUNITS'
4644       include 'COMMON.CONTROL'
4645       include 'COMMON.SPLITELE'
4646       dimension ggg(3)
4647       evdw2=0.0D0
4648       evdw2_14=0.0d0
4649 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4650 cd    print '(a)','Enter ESCP'
4651 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4652 C      do xshift=-1,1
4653 C      do yshift=-1,1
4654 C      do zshift=-1,1
4655       do i=iatscp_s,iatscp_e
4656         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4657         iteli=itel(i)
4658         xi=0.5D0*(c(1,i)+c(1,i+1))
4659         yi=0.5D0*(c(2,i)+c(2,i+1))
4660         zi=0.5D0*(c(3,i)+c(3,i+1))
4661           xi=mod(xi,boxxsize)
4662           if (xi.lt.0) xi=xi+boxxsize
4663           yi=mod(yi,boxysize)
4664           if (yi.lt.0) yi=yi+boxysize
4665           zi=mod(zi,boxzsize)
4666           if (zi.lt.0) zi=zi+boxzsize
4667 c          xi=xi+xshift*boxxsize
4668 c          yi=yi+yshift*boxysize
4669 c          zi=zi+zshift*boxzsize
4670 c        print *,xi,yi,zi,'polozenie i'
4671 C Return atom into box, boxxsize is size of box in x dimension
4672 c  134   continue
4673 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4674 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4675 C Condition for being inside the proper box
4676 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4677 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4678 c        go to 134
4679 c        endif
4680 c  135   continue
4681 c          print *,xi,boxxsize,"pierwszy"
4682
4683 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4684 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4685 C Condition for being inside the proper box
4686 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4687 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4688 c        go to 135
4689 c        endif
4690 c  136   continue
4691 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4692 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4693 C Condition for being inside the proper box
4694 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4695 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4696 c        go to 136
4697 c        endif
4698         do iint=1,nscp_gr(i)
4699
4700         do j=iscpstart(i,iint),iscpend(i,iint)
4701           itypj=iabs(itype(j))
4702           if (itypj.eq.ntyp1) cycle
4703 C Uncomment following three lines for SC-p interactions
4704 c         xj=c(1,nres+j)-xi
4705 c         yj=c(2,nres+j)-yi
4706 c         zj=c(3,nres+j)-zi
4707 C Uncomment following three lines for Ca-p interactions
4708           xj=c(1,j)
4709           yj=c(2,j)
4710           zj=c(3,j)
4711           xj=mod(xj,boxxsize)
4712           if (xj.lt.0) xj=xj+boxxsize
4713           yj=mod(yj,boxysize)
4714           if (yj.lt.0) yj=yj+boxysize
4715           zj=mod(zj,boxzsize)
4716           if (zj.lt.0) zj=zj+boxzsize
4717 c  174   continue
4718 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4719 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4720 C Condition for being inside the proper box
4721 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4722 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4723 c        go to 174
4724 c        endif
4725 c  175   continue
4726 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4727 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4728 cC Condition for being inside the proper box
4729 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4730 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4731 c        go to 175
4732 c        endif
4733 c  176   continue
4734 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4735 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4736 C Condition for being inside the proper box
4737 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4738 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4739 c        go to 176
4740 c        endif
4741 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4742       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4743       xj_safe=xj
4744       yj_safe=yj
4745       zj_safe=zj
4746       subchap=0
4747       do xshift=-1,1
4748       do yshift=-1,1
4749       do zshift=-1,1
4750           xj=xj_safe+xshift*boxxsize
4751           yj=yj_safe+yshift*boxysize
4752           zj=zj_safe+zshift*boxzsize
4753           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4754           if(dist_temp.lt.dist_init) then
4755             dist_init=dist_temp
4756             xj_temp=xj
4757             yj_temp=yj
4758             zj_temp=zj
4759             subchap=1
4760           endif
4761        enddo
4762        enddo
4763        enddo
4764        if (subchap.eq.1) then
4765           xj=xj_temp-xi
4766           yj=yj_temp-yi
4767           zj=zj_temp-zi
4768        else
4769           xj=xj_safe-xi
4770           yj=yj_safe-yi
4771           zj=zj_safe-zi
4772        endif
4773 c          print *,xj,yj,zj,'polozenie j'
4774           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4775 c          print *,rrij
4776           sss=sscale(1.0d0/(dsqrt(rrij)))
4777 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4778 c          if (sss.eq.0) print *,'czasem jest OK'
4779           if (sss.le.0.0d0) cycle
4780           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4781           fac=rrij**expon2
4782           e1=fac*fac*aad(itypj,iteli)
4783           e2=fac*bad(itypj,iteli)
4784           if (iabs(j-i) .le. 2) then
4785             e1=scal14*e1
4786             e2=scal14*e2
4787             evdw2_14=evdw2_14+(e1+e2)*sss
4788           endif
4789           evdwij=e1+e2
4790           evdw2=evdw2+evdwij*sss
4791           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4792      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4793      &       bad(itypj,iteli)
4794 C
4795 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4796 C
4797           fac=-(evdwij+e1)*rrij*sss
4798           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4799           ggg(1)=xj*fac
4800           ggg(2)=yj*fac
4801           ggg(3)=zj*fac
4802 cgrad          if (j.lt.i) then
4803 cd          write (iout,*) 'j<i'
4804 C Uncomment following three lines for SC-p interactions
4805 c           do k=1,3
4806 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4807 c           enddo
4808 cgrad          else
4809 cd          write (iout,*) 'j>i'
4810 cgrad            do k=1,3
4811 cgrad              ggg(k)=-ggg(k)
4812 C Uncomment following line for SC-p interactions
4813 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4814 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4815 cgrad            enddo
4816 cgrad          endif
4817 cgrad          do k=1,3
4818 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4819 cgrad          enddo
4820 cgrad          kstart=min0(i+1,j)
4821 cgrad          kend=max0(i-1,j-1)
4822 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4823 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4824 cgrad          do k=kstart,kend
4825 cgrad            do l=1,3
4826 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4827 cgrad            enddo
4828 cgrad          enddo
4829           do k=1,3
4830             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4831             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4832           enddo
4833 c        endif !endif for sscale cutoff
4834         enddo ! j
4835
4836         enddo ! iint
4837       enddo ! i
4838 c      enddo !zshift
4839 c      enddo !yshift
4840 c      enddo !xshift
4841       do i=1,nct
4842         do j=1,3
4843           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4844           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4845           gradx_scp(j,i)=expon*gradx_scp(j,i)
4846         enddo
4847       enddo
4848 C******************************************************************************
4849 C
4850 C                              N O T E !!!
4851 C
4852 C To save time the factor EXPON has been extracted from ALL components
4853 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4854 C use!
4855 C
4856 C******************************************************************************
4857       return
4858       end
4859 C--------------------------------------------------------------------------
4860       subroutine edis(ehpb)
4861 C
4862 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4863 C
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.SBRIDGE'
4867       include 'COMMON.CHAIN'
4868       include 'COMMON.DERIV'
4869       include 'COMMON.VAR'
4870       include 'COMMON.INTERACT'
4871       include 'COMMON.IOUNITS'
4872       dimension ggg(3)
4873       ehpb=0.0D0
4874 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4875 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4876       if (link_end.eq.0) return
4877       do i=link_start,link_end
4878 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4879 C CA-CA distance used in regularization of structure.
4880         ii=ihpb(i)
4881         jj=jhpb(i)
4882 C iii and jjj point to the residues for which the distance is assigned.
4883         if (ii.gt.nres) then
4884           iii=ii-nres
4885           jjj=jj-nres
4886         else
4887           iii=ii
4888           jjj=jj
4889         endif
4890 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4891 c     &    dhpb(i),dhpb1(i),forcon(i)
4892 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4893 C    distance and angle dependent SS bond potential.
4894         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4895      & iabs(itype(jjj)).eq.1) then
4896 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4897 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4898         if (.not.dyn_ss .and. i.le.nss) then
4899 C 15/02/13 CC dynamic SSbond - additional check
4900          if (ii.gt.nres
4901      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4902           call ssbond_ene(iii,jjj,eij)
4903           ehpb=ehpb+2*eij
4904          endif
4905 cd          write (iout,*) "eij",eij
4906         else
4907 C Calculate the distance between the two points and its difference from the
4908 C target distance.
4909           dd=dist(ii,jj)
4910             rdis=dd-dhpb(i)
4911 C Get the force constant corresponding to this distance.
4912             waga=forcon(i)
4913 C Calculate the contribution to energy.
4914             ehpb=ehpb+waga*rdis*rdis
4915 C
4916 C Evaluate gradient.
4917 C
4918             fac=waga*rdis/dd
4919 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4920 cd   &   ' waga=',waga,' fac=',fac
4921             do j=1,3
4922               ggg(j)=fac*(c(j,jj)-c(j,ii))
4923             enddo
4924 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4925 C If this is a SC-SC distance, we need to calculate the contributions to the
4926 C Cartesian gradient in the SC vectors (ghpbx).
4927           if (iii.lt.ii) then
4928           do j=1,3
4929             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4930             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4931           enddo
4932           endif
4933 cgrad        do j=iii,jjj-1
4934 cgrad          do k=1,3
4935 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4936 cgrad          enddo
4937 cgrad        enddo
4938           do k=1,3
4939             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4940             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4941           enddo
4942         endif
4943        endif
4944       enddo
4945       ehpb=0.5D0*ehpb
4946       return
4947       end
4948 C--------------------------------------------------------------------------
4949       subroutine ssbond_ene(i,j,eij)
4950 C
4951 C Calculate the distance and angle dependent SS-bond potential energy
4952 C using a free-energy function derived based on RHF/6-31G** ab initio
4953 C calculations of diethyl disulfide.
4954 C
4955 C A. Liwo and U. Kozlowska, 11/24/03
4956 C
4957       implicit real*8 (a-h,o-z)
4958       include 'DIMENSIONS'
4959       include 'COMMON.SBRIDGE'
4960       include 'COMMON.CHAIN'
4961       include 'COMMON.DERIV'
4962       include 'COMMON.LOCAL'
4963       include 'COMMON.INTERACT'
4964       include 'COMMON.VAR'
4965       include 'COMMON.IOUNITS'
4966       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4967       itypi=iabs(itype(i))
4968       xi=c(1,nres+i)
4969       yi=c(2,nres+i)
4970       zi=c(3,nres+i)
4971       dxi=dc_norm(1,nres+i)
4972       dyi=dc_norm(2,nres+i)
4973       dzi=dc_norm(3,nres+i)
4974 c      dsci_inv=dsc_inv(itypi)
4975       dsci_inv=vbld_inv(nres+i)
4976       itypj=iabs(itype(j))
4977 c      dscj_inv=dsc_inv(itypj)
4978       dscj_inv=vbld_inv(nres+j)
4979       xj=c(1,nres+j)-xi
4980       yj=c(2,nres+j)-yi
4981       zj=c(3,nres+j)-zi
4982       dxj=dc_norm(1,nres+j)
4983       dyj=dc_norm(2,nres+j)
4984       dzj=dc_norm(3,nres+j)
4985       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4986       rij=dsqrt(rrij)
4987       erij(1)=xj*rij
4988       erij(2)=yj*rij
4989       erij(3)=zj*rij
4990       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4991       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4992       om12=dxi*dxj+dyi*dyj+dzi*dzj
4993       do k=1,3
4994         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4995         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4996       enddo
4997       rij=1.0d0/rij
4998       deltad=rij-d0cm
4999       deltat1=1.0d0-om1
5000       deltat2=1.0d0+om2
5001       deltat12=om2-om1+2.0d0
5002       cosphi=om12-om1*om2
5003       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5004      &  +akct*deltad*deltat12
5005      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5006 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5007 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5008 c     &  " deltat12",deltat12," eij",eij
5009       ed=2*akcm*deltad+akct*deltat12
5010       pom1=akct*deltad
5011       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5012       eom1=-2*akth*deltat1-pom1-om2*pom2
5013       eom2= 2*akth*deltat2+pom1-om1*pom2
5014       eom12=pom2
5015       do k=1,3
5016         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5017         ghpbx(k,i)=ghpbx(k,i)-ggk
5018      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5019      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5020         ghpbx(k,j)=ghpbx(k,j)+ggk
5021      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5022      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5023         ghpbc(k,i)=ghpbc(k,i)-ggk
5024         ghpbc(k,j)=ghpbc(k,j)+ggk
5025       enddo
5026 C
5027 C Calculate the components of the gradient in DC and X
5028 C
5029 cgrad      do k=i,j-1
5030 cgrad        do l=1,3
5031 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5032 cgrad        enddo
5033 cgrad      enddo
5034       return
5035       end
5036 C--------------------------------------------------------------------------
5037       subroutine ebond(estr)
5038 c
5039 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5040 c
5041       implicit real*8 (a-h,o-z)
5042       include 'DIMENSIONS'
5043       include 'COMMON.LOCAL'
5044       include 'COMMON.GEO'
5045       include 'COMMON.INTERACT'
5046       include 'COMMON.DERIV'
5047       include 'COMMON.VAR'
5048       include 'COMMON.CHAIN'
5049       include 'COMMON.IOUNITS'
5050       include 'COMMON.NAMES'
5051       include 'COMMON.FFIELD'
5052       include 'COMMON.CONTROL'
5053       include 'COMMON.SETUP'
5054       double precision u(3),ud(3)
5055       estr=0.0d0
5056       estr1=0.0d0
5057       do i=ibondp_start,ibondp_end
5058         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5059 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5060 c          do j=1,3
5061 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5062 c     &      *dc(j,i-1)/vbld(i)
5063 c          enddo
5064 c          if (energy_dec) write(iout,*)
5065 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5066 c        else
5067 C       Checking if it involves dummy (NH3+ or COO-) group
5068          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5069 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5070         diff = vbld(i)-vbldpDUM
5071          else
5072 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5073         diff = vbld(i)-vbldp0
5074          endif
5075         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5076      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5077         estr=estr+diff*diff
5078         do j=1,3
5079           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5080         enddo
5081 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5082 c        endif
5083       enddo
5084       estr=0.5d0*AKP*estr+estr1
5085 c
5086 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5087 c
5088       do i=ibond_start,ibond_end
5089         iti=iabs(itype(i))
5090         if (iti.ne.10 .and. iti.ne.ntyp1) then
5091           nbi=nbondterm(iti)
5092           if (nbi.eq.1) then
5093             diff=vbld(i+nres)-vbldsc0(1,iti)
5094             if (energy_dec)  write (iout,*)
5095      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5096      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5097             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5098             do j=1,3
5099               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5100             enddo
5101           else
5102             do j=1,nbi
5103               diff=vbld(i+nres)-vbldsc0(j,iti)
5104               ud(j)=aksc(j,iti)*diff
5105               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5106             enddo
5107             uprod=u(1)
5108             do j=2,nbi
5109               uprod=uprod*u(j)
5110             enddo
5111             usum=0.0d0
5112             usumsqder=0.0d0
5113             do j=1,nbi
5114               uprod1=1.0d0
5115               uprod2=1.0d0
5116               do k=1,nbi
5117                 if (k.ne.j) then
5118                   uprod1=uprod1*u(k)
5119                   uprod2=uprod2*u(k)*u(k)
5120                 endif
5121               enddo
5122               usum=usum+uprod1
5123               usumsqder=usumsqder+ud(j)*uprod2
5124             enddo
5125             estr=estr+uprod/usum
5126             do j=1,3
5127              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5128             enddo
5129           endif
5130         endif
5131       enddo
5132       return
5133       end
5134 #ifdef CRYST_THETA
5135 C--------------------------------------------------------------------------
5136       subroutine ebend(etheta)
5137 C
5138 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5139 C angles gamma and its derivatives in consecutive thetas and gammas.
5140 C
5141       implicit real*8 (a-h,o-z)
5142       include 'DIMENSIONS'
5143       include 'COMMON.LOCAL'
5144       include 'COMMON.GEO'
5145       include 'COMMON.INTERACT'
5146       include 'COMMON.DERIV'
5147       include 'COMMON.VAR'
5148       include 'COMMON.CHAIN'
5149       include 'COMMON.IOUNITS'
5150       include 'COMMON.NAMES'
5151       include 'COMMON.FFIELD'
5152       include 'COMMON.CONTROL'
5153       common /calcthet/ term1,term2,termm,diffak,ratak,
5154      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5155      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5156       double precision y(2),z(2)
5157       delta=0.02d0*pi
5158 c      time11=dexp(-2*time)
5159 c      time12=1.0d0
5160       etheta=0.0D0
5161 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5162       do i=ithet_start,ithet_end
5163         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5164      &  .or.itype(i).eq.ntyp1) cycle
5165 C Zero the energy function and its derivative at 0 or pi.
5166         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5167         it=itype(i-1)
5168         ichir1=isign(1,itype(i-2))
5169         ichir2=isign(1,itype(i))
5170          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5171          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5172          if (itype(i-1).eq.10) then
5173           itype1=isign(10,itype(i-2))
5174           ichir11=isign(1,itype(i-2))
5175           ichir12=isign(1,itype(i-2))
5176           itype2=isign(10,itype(i))
5177           ichir21=isign(1,itype(i))
5178           ichir22=isign(1,itype(i))
5179          endif
5180
5181         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5182 #ifdef OSF
5183           phii=phi(i)
5184           if (phii.ne.phii) phii=150.0
5185 #else
5186           phii=phi(i)
5187 #endif
5188           y(1)=dcos(phii)
5189           y(2)=dsin(phii)
5190         else
5191           y(1)=0.0D0
5192           y(2)=0.0D0
5193         endif
5194         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5195 #ifdef OSF
5196           phii1=phi(i+1)
5197           if (phii1.ne.phii1) phii1=150.0
5198           phii1=pinorm(phii1)
5199           z(1)=cos(phii1)
5200 #else
5201           phii1=phi(i+1)
5202 #endif
5203           z(1)=dcos(phii1)
5204           z(2)=dsin(phii1)
5205         else
5206           z(1)=0.0D0
5207           z(2)=0.0D0
5208         endif
5209 C Calculate the "mean" value of theta from the part of the distribution
5210 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5211 C In following comments this theta will be referred to as t_c.
5212         thet_pred_mean=0.0d0
5213         do k=1,2
5214             athetk=athet(k,it,ichir1,ichir2)
5215             bthetk=bthet(k,it,ichir1,ichir2)
5216           if (it.eq.10) then
5217              athetk=athet(k,itype1,ichir11,ichir12)
5218              bthetk=bthet(k,itype2,ichir21,ichir22)
5219           endif
5220          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5221 c         write(iout,*) 'chuj tu', y(k),z(k)
5222         enddo
5223         dthett=thet_pred_mean*ssd
5224         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5225 C Derivatives of the "mean" values in gamma1 and gamma2.
5226         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5227      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5228          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5229      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5230          if (it.eq.10) then
5231       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5232      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5233         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5234      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5235          endif
5236         if (theta(i).gt.pi-delta) then
5237           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5238      &         E_tc0)
5239           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5240           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5241           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5242      &        E_theta)
5243           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5244      &        E_tc)
5245         else if (theta(i).lt.delta) then
5246           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5247           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5248           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5249      &        E_theta)
5250           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5251           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5252      &        E_tc)
5253         else
5254           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5255      &        E_theta,E_tc)
5256         endif
5257         etheta=etheta+ethetai
5258         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5259      &      'ebend',i,ethetai,theta(i),itype(i)
5260         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5261         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5262         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5263       enddo
5264 C Ufff.... We've done all this!!!
5265       return
5266       end
5267 C---------------------------------------------------------------------------
5268       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5269      &     E_tc)
5270       implicit real*8 (a-h,o-z)
5271       include 'DIMENSIONS'
5272       include 'COMMON.LOCAL'
5273       include 'COMMON.IOUNITS'
5274       common /calcthet/ term1,term2,termm,diffak,ratak,
5275      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5276      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5277 C Calculate the contributions to both Gaussian lobes.
5278 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5279 C The "polynomial part" of the "standard deviation" of this part of
5280 C the distributioni.
5281 ccc        write (iout,*) thetai,thet_pred_mean
5282         sig=polthet(3,it)
5283         do j=2,0,-1
5284           sig=sig*thet_pred_mean+polthet(j,it)
5285         enddo
5286 C Derivative of the "interior part" of the "standard deviation of the"
5287 C gamma-dependent Gaussian lobe in t_c.
5288         sigtc=3*polthet(3,it)
5289         do j=2,1,-1
5290           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5291         enddo
5292         sigtc=sig*sigtc
5293 C Set the parameters of both Gaussian lobes of the distribution.
5294 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5295         fac=sig*sig+sigc0(it)
5296         sigcsq=fac+fac
5297         sigc=1.0D0/sigcsq
5298 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5299         sigsqtc=-4.0D0*sigcsq*sigtc
5300 c       print *,i,sig,sigtc,sigsqtc
5301 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5302         sigtc=-sigtc/(fac*fac)
5303 C Following variable is sigma(t_c)**(-2)
5304         sigcsq=sigcsq*sigcsq
5305         sig0i=sig0(it)
5306         sig0inv=1.0D0/sig0i**2
5307         delthec=thetai-thet_pred_mean
5308         delthe0=thetai-theta0i
5309         term1=-0.5D0*sigcsq*delthec*delthec
5310         term2=-0.5D0*sig0inv*delthe0*delthe0
5311 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5312 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5313 C NaNs in taking the logarithm. We extract the largest exponent which is added
5314 C to the energy (this being the log of the distribution) at the end of energy
5315 C term evaluation for this virtual-bond angle.
5316         if (term1.gt.term2) then
5317           termm=term1
5318           term2=dexp(term2-termm)
5319           term1=1.0d0
5320         else
5321           termm=term2
5322           term1=dexp(term1-termm)
5323           term2=1.0d0
5324         endif
5325 C The ratio between the gamma-independent and gamma-dependent lobes of
5326 C the distribution is a Gaussian function of thet_pred_mean too.
5327         diffak=gthet(2,it)-thet_pred_mean
5328         ratak=diffak/gthet(3,it)**2
5329         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5330 C Let's differentiate it in thet_pred_mean NOW.
5331         aktc=ak*ratak
5332 C Now put together the distribution terms to make complete distribution.
5333         termexp=term1+ak*term2
5334         termpre=sigc+ak*sig0i
5335 C Contribution of the bending energy from this theta is just the -log of
5336 C the sum of the contributions from the two lobes and the pre-exponential
5337 C factor. Simple enough, isn't it?
5338         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5339 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5340 C NOW the derivatives!!!
5341 C 6/6/97 Take into account the deformation.
5342         E_theta=(delthec*sigcsq*term1
5343      &       +ak*delthe0*sig0inv*term2)/termexp
5344         E_tc=((sigtc+aktc*sig0i)/termpre
5345      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5346      &       aktc*term2)/termexp)
5347       return
5348       end
5349 c-----------------------------------------------------------------------------
5350       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5351       implicit real*8 (a-h,o-z)
5352       include 'DIMENSIONS'
5353       include 'COMMON.LOCAL'
5354       include 'COMMON.IOUNITS'
5355       common /calcthet/ term1,term2,termm,diffak,ratak,
5356      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5357      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5358       delthec=thetai-thet_pred_mean
5359       delthe0=thetai-theta0i
5360 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5361       t3 = thetai-thet_pred_mean
5362       t6 = t3**2
5363       t9 = term1
5364       t12 = t3*sigcsq
5365       t14 = t12+t6*sigsqtc
5366       t16 = 1.0d0
5367       t21 = thetai-theta0i
5368       t23 = t21**2
5369       t26 = term2
5370       t27 = t21*t26
5371       t32 = termexp
5372       t40 = t32**2
5373       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5374      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5375      & *(-t12*t9-ak*sig0inv*t27)
5376       return
5377       end
5378 #else
5379 C--------------------------------------------------------------------------
5380       subroutine ebend(etheta)
5381 C
5382 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5383 C angles gamma and its derivatives in consecutive thetas and gammas.
5384 C ab initio-derived potentials from
5385 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5386 C
5387       implicit real*8 (a-h,o-z)
5388       include 'DIMENSIONS'
5389       include 'COMMON.LOCAL'
5390       include 'COMMON.GEO'
5391       include 'COMMON.INTERACT'
5392       include 'COMMON.DERIV'
5393       include 'COMMON.VAR'
5394       include 'COMMON.CHAIN'
5395       include 'COMMON.IOUNITS'
5396       include 'COMMON.NAMES'
5397       include 'COMMON.FFIELD'
5398       include 'COMMON.CONTROL'
5399       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5400      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5401      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5402      & sinph1ph2(maxdouble,maxdouble)
5403       logical lprn /.false./, lprn1 /.false./
5404       etheta=0.0D0
5405       do i=ithet_start,ithet_end
5406 c        print *,i,itype(i-1),itype(i),itype(i-2)
5407         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5408      &  .or.itype(i).eq.ntyp1) cycle
5409 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5410
5411         if (iabs(itype(i+1)).eq.20) iblock=2
5412         if (iabs(itype(i+1)).ne.20) iblock=1
5413         dethetai=0.0d0
5414         dephii=0.0d0
5415         dephii1=0.0d0
5416         theti2=0.5d0*theta(i)
5417         ityp2=ithetyp((itype(i-1)))
5418         do k=1,nntheterm
5419           coskt(k)=dcos(k*theti2)
5420           sinkt(k)=dsin(k*theti2)
5421         enddo
5422         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5423 #ifdef OSF
5424           phii=phi(i)
5425           if (phii.ne.phii) phii=150.0
5426 #else
5427           phii=phi(i)
5428 #endif
5429           ityp1=ithetyp((itype(i-2)))
5430 C propagation of chirality for glycine type
5431           do k=1,nsingle
5432             cosph1(k)=dcos(k*phii)
5433             sinph1(k)=dsin(k*phii)
5434           enddo
5435         else
5436           phii=0.0d0
5437           ityp1=nthetyp+1
5438           do k=1,nsingle
5439             cosph1(k)=0.0d0
5440             sinph1(k)=0.0d0
5441           enddo
5442         endif
5443         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5444 #ifdef OSF
5445           phii1=phi(i+1)
5446           if (phii1.ne.phii1) phii1=150.0
5447           phii1=pinorm(phii1)
5448 #else
5449           phii1=phi(i+1)
5450 #endif
5451           ityp3=ithetyp((itype(i)))
5452           do k=1,nsingle
5453             cosph2(k)=dcos(k*phii1)
5454             sinph2(k)=dsin(k*phii1)
5455           enddo
5456         else
5457           phii1=0.0d0
5458           ityp3=nthetyp+1
5459           do k=1,nsingle
5460             cosph2(k)=0.0d0
5461             sinph2(k)=0.0d0
5462           enddo
5463         endif
5464         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5465         do k=1,ndouble
5466           do l=1,k-1
5467             ccl=cosph1(l)*cosph2(k-l)
5468             ssl=sinph1(l)*sinph2(k-l)
5469             scl=sinph1(l)*cosph2(k-l)
5470             csl=cosph1(l)*sinph2(k-l)
5471             cosph1ph2(l,k)=ccl-ssl
5472             cosph1ph2(k,l)=ccl+ssl
5473             sinph1ph2(l,k)=scl+csl
5474             sinph1ph2(k,l)=scl-csl
5475           enddo
5476         enddo
5477         if (lprn) then
5478         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5479      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5480         write (iout,*) "coskt and sinkt"
5481         do k=1,nntheterm
5482           write (iout,*) k,coskt(k),sinkt(k)
5483         enddo
5484         endif
5485         do k=1,ntheterm
5486           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5487           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5488      &      *coskt(k)
5489           if (lprn)
5490      &    write (iout,*) "k",k,"
5491      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5492      &     " ethetai",ethetai
5493         enddo
5494         if (lprn) then
5495         write (iout,*) "cosph and sinph"
5496         do k=1,nsingle
5497           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5498         enddo
5499         write (iout,*) "cosph1ph2 and sinph2ph2"
5500         do k=2,ndouble
5501           do l=1,k-1
5502             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5503      &         sinph1ph2(l,k),sinph1ph2(k,l)
5504           enddo
5505         enddo
5506         write(iout,*) "ethetai",ethetai
5507         endif
5508         do m=1,ntheterm2
5509           do k=1,nsingle
5510             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5511      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5512      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5513      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5514             ethetai=ethetai+sinkt(m)*aux
5515             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5516             dephii=dephii+k*sinkt(m)*(
5517      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5518      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5519             dephii1=dephii1+k*sinkt(m)*(
5520      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5521      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5522             if (lprn)
5523      &      write (iout,*) "m",m," k",k," bbthet",
5524      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5525      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5526      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5527      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5528           enddo
5529         enddo
5530         if (lprn)
5531      &  write(iout,*) "ethetai",ethetai
5532         do m=1,ntheterm3
5533           do k=2,ndouble
5534             do l=1,k-1
5535               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5536      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5537      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5538      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5539               ethetai=ethetai+sinkt(m)*aux
5540               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5541               dephii=dephii+l*sinkt(m)*(
5542      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5543      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5544      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5545      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5546               dephii1=dephii1+(k-l)*sinkt(m)*(
5547      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5548      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5549      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5550      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5551               if (lprn) then
5552               write (iout,*) "m",m," k",k," l",l," ffthet",
5553      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5554      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5555      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5556      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5557      &            " ethetai",ethetai
5558               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5559      &            cosph1ph2(k,l)*sinkt(m),
5560      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5561               endif
5562             enddo
5563           enddo
5564         enddo
5565 10      continue
5566 c        lprn1=.true.
5567         if (lprn1)
5568      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5569      &   i,theta(i)*rad2deg,phii*rad2deg,
5570      &   phii1*rad2deg,ethetai
5571 c        lprn1=.false.
5572         etheta=etheta+ethetai
5573         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5574         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5575         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5576       enddo
5577       return
5578       end
5579 #endif
5580 #ifdef CRYST_SC
5581 c-----------------------------------------------------------------------------
5582       subroutine esc(escloc)
5583 C Calculate the local energy of a side chain and its derivatives in the
5584 C corresponding virtual-bond valence angles THETA and the spherical angles
5585 C ALPHA and OMEGA.
5586       implicit real*8 (a-h,o-z)
5587       include 'DIMENSIONS'
5588       include 'COMMON.GEO'
5589       include 'COMMON.LOCAL'
5590       include 'COMMON.VAR'
5591       include 'COMMON.INTERACT'
5592       include 'COMMON.DERIV'
5593       include 'COMMON.CHAIN'
5594       include 'COMMON.IOUNITS'
5595       include 'COMMON.NAMES'
5596       include 'COMMON.FFIELD'
5597       include 'COMMON.CONTROL'
5598       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5599      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5600       common /sccalc/ time11,time12,time112,theti,it,nlobit
5601       delta=0.02d0*pi
5602       escloc=0.0D0
5603 c     write (iout,'(a)') 'ESC'
5604       do i=loc_start,loc_end
5605         it=itype(i)
5606         if (it.eq.ntyp1) cycle
5607         if (it.eq.10) goto 1
5608         nlobit=nlob(iabs(it))
5609 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5610 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5611         theti=theta(i+1)-pipol
5612         x(1)=dtan(theti)
5613         x(2)=alph(i)
5614         x(3)=omeg(i)
5615
5616         if (x(2).gt.pi-delta) then
5617           xtemp(1)=x(1)
5618           xtemp(2)=pi-delta
5619           xtemp(3)=x(3)
5620           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5621           xtemp(2)=pi
5622           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5623           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5624      &        escloci,dersc(2))
5625           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5626      &        ddersc0(1),dersc(1))
5627           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5628      &        ddersc0(3),dersc(3))
5629           xtemp(2)=pi-delta
5630           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5631           xtemp(2)=pi
5632           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5633           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5634      &            dersc0(2),esclocbi,dersc02)
5635           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5636      &            dersc12,dersc01)
5637           call splinthet(x(2),0.5d0*delta,ss,ssd)
5638           dersc0(1)=dersc01
5639           dersc0(2)=dersc02
5640           dersc0(3)=0.0d0
5641           do k=1,3
5642             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5643           enddo
5644           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5645 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5646 c    &             esclocbi,ss,ssd
5647           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5648 c         escloci=esclocbi
5649 c         write (iout,*) escloci
5650         else if (x(2).lt.delta) then
5651           xtemp(1)=x(1)
5652           xtemp(2)=delta
5653           xtemp(3)=x(3)
5654           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5655           xtemp(2)=0.0d0
5656           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5657           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5658      &        escloci,dersc(2))
5659           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5660      &        ddersc0(1),dersc(1))
5661           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5662      &        ddersc0(3),dersc(3))
5663           xtemp(2)=delta
5664           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5665           xtemp(2)=0.0d0
5666           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5667           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5668      &            dersc0(2),esclocbi,dersc02)
5669           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5670      &            dersc12,dersc01)
5671           dersc0(1)=dersc01
5672           dersc0(2)=dersc02
5673           dersc0(3)=0.0d0
5674           call splinthet(x(2),0.5d0*delta,ss,ssd)
5675           do k=1,3
5676             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5677           enddo
5678           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5679 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5680 c    &             esclocbi,ss,ssd
5681           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5682 c         write (iout,*) escloci
5683         else
5684           call enesc(x,escloci,dersc,ddummy,.false.)
5685         endif
5686
5687         escloc=escloc+escloci
5688         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5689      &     'escloc',i,escloci
5690 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5691
5692         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5693      &   wscloc*dersc(1)
5694         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5695         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5696     1   continue
5697       enddo
5698       return
5699       end
5700 C---------------------------------------------------------------------------
5701       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5702       implicit real*8 (a-h,o-z)
5703       include 'DIMENSIONS'
5704       include 'COMMON.GEO'
5705       include 'COMMON.LOCAL'
5706       include 'COMMON.IOUNITS'
5707       common /sccalc/ time11,time12,time112,theti,it,nlobit
5708       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5709       double precision contr(maxlob,-1:1)
5710       logical mixed
5711 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5712         escloc_i=0.0D0
5713         do j=1,3
5714           dersc(j)=0.0D0
5715           if (mixed) ddersc(j)=0.0d0
5716         enddo
5717         x3=x(3)
5718
5719 C Because of periodicity of the dependence of the SC energy in omega we have
5720 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5721 C To avoid underflows, first compute & store the exponents.
5722
5723         do iii=-1,1
5724
5725           x(3)=x3+iii*dwapi
5726
5727           do j=1,nlobit
5728             do k=1,3
5729               z(k)=x(k)-censc(k,j,it)
5730             enddo
5731             do k=1,3
5732               Axk=0.0D0
5733               do l=1,3
5734                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5735               enddo
5736               Ax(k,j,iii)=Axk
5737             enddo
5738             expfac=0.0D0
5739             do k=1,3
5740               expfac=expfac+Ax(k,j,iii)*z(k)
5741             enddo
5742             contr(j,iii)=expfac
5743           enddo ! j
5744
5745         enddo ! iii
5746
5747         x(3)=x3
5748 C As in the case of ebend, we want to avoid underflows in exponentiation and
5749 C subsequent NaNs and INFs in energy calculation.
5750 C Find the largest exponent
5751         emin=contr(1,-1)
5752         do iii=-1,1
5753           do j=1,nlobit
5754             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5755           enddo
5756         enddo
5757         emin=0.5D0*emin
5758 cd      print *,'it=',it,' emin=',emin
5759
5760 C Compute the contribution to SC energy and derivatives
5761         do iii=-1,1
5762
5763           do j=1,nlobit
5764 #ifdef OSF
5765             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5766             if(adexp.ne.adexp) adexp=1.0
5767             expfac=dexp(adexp)
5768 #else
5769             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5770 #endif
5771 cd          print *,'j=',j,' expfac=',expfac
5772             escloc_i=escloc_i+expfac
5773             do k=1,3
5774               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5775             enddo
5776             if (mixed) then
5777               do k=1,3,2
5778                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5779      &            +gaussc(k,2,j,it))*expfac
5780               enddo
5781             endif
5782           enddo
5783
5784         enddo ! iii
5785
5786         dersc(1)=dersc(1)/cos(theti)**2
5787         ddersc(1)=ddersc(1)/cos(theti)**2
5788         ddersc(3)=ddersc(3)
5789
5790         escloci=-(dlog(escloc_i)-emin)
5791         do j=1,3
5792           dersc(j)=dersc(j)/escloc_i
5793         enddo
5794         if (mixed) then
5795           do j=1,3,2
5796             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5797           enddo
5798         endif
5799       return
5800       end
5801 C------------------------------------------------------------------------------
5802       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5803       implicit real*8 (a-h,o-z)
5804       include 'DIMENSIONS'
5805       include 'COMMON.GEO'
5806       include 'COMMON.LOCAL'
5807       include 'COMMON.IOUNITS'
5808       common /sccalc/ time11,time12,time112,theti,it,nlobit
5809       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5810       double precision contr(maxlob)
5811       logical mixed
5812
5813       escloc_i=0.0D0
5814
5815       do j=1,3
5816         dersc(j)=0.0D0
5817       enddo
5818
5819       do j=1,nlobit
5820         do k=1,2
5821           z(k)=x(k)-censc(k,j,it)
5822         enddo
5823         z(3)=dwapi
5824         do k=1,3
5825           Axk=0.0D0
5826           do l=1,3
5827             Axk=Axk+gaussc(l,k,j,it)*z(l)
5828           enddo
5829           Ax(k,j)=Axk
5830         enddo
5831         expfac=0.0D0
5832         do k=1,3
5833           expfac=expfac+Ax(k,j)*z(k)
5834         enddo
5835         contr(j)=expfac
5836       enddo ! j
5837
5838 C As in the case of ebend, we want to avoid underflows in exponentiation and
5839 C subsequent NaNs and INFs in energy calculation.
5840 C Find the largest exponent
5841       emin=contr(1)
5842       do j=1,nlobit
5843         if (emin.gt.contr(j)) emin=contr(j)
5844       enddo
5845       emin=0.5D0*emin
5846
5847 C Compute the contribution to SC energy and derivatives
5848
5849       dersc12=0.0d0
5850       do j=1,nlobit
5851         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5852         escloc_i=escloc_i+expfac
5853         do k=1,2
5854           dersc(k)=dersc(k)+Ax(k,j)*expfac
5855         enddo
5856         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5857      &            +gaussc(1,2,j,it))*expfac
5858         dersc(3)=0.0d0
5859       enddo
5860
5861       dersc(1)=dersc(1)/cos(theti)**2
5862       dersc12=dersc12/cos(theti)**2
5863       escloci=-(dlog(escloc_i)-emin)
5864       do j=1,2
5865         dersc(j)=dersc(j)/escloc_i
5866       enddo
5867       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5868       return
5869       end
5870 #else
5871 c----------------------------------------------------------------------------------
5872       subroutine esc(escloc)
5873 C Calculate the local energy of a side chain and its derivatives in the
5874 C corresponding virtual-bond valence angles THETA and the spherical angles
5875 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5876 C added by Urszula Kozlowska. 07/11/2007
5877 C
5878       implicit real*8 (a-h,o-z)
5879       include 'DIMENSIONS'
5880       include 'COMMON.GEO'
5881       include 'COMMON.LOCAL'
5882       include 'COMMON.VAR'
5883       include 'COMMON.SCROT'
5884       include 'COMMON.INTERACT'
5885       include 'COMMON.DERIV'
5886       include 'COMMON.CHAIN'
5887       include 'COMMON.IOUNITS'
5888       include 'COMMON.NAMES'
5889       include 'COMMON.FFIELD'
5890       include 'COMMON.CONTROL'
5891       include 'COMMON.VECTORS'
5892       double precision x_prime(3),y_prime(3),z_prime(3)
5893      &    , sumene,dsc_i,dp2_i,x(65),
5894      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5895      &    de_dxx,de_dyy,de_dzz,de_dt
5896       double precision s1_t,s1_6_t,s2_t,s2_6_t
5897       double precision
5898      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5899      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5900      & dt_dCi(3),dt_dCi1(3)
5901       common /sccalc/ time11,time12,time112,theti,it,nlobit
5902       delta=0.02d0*pi
5903       escloc=0.0D0
5904       do i=loc_start,loc_end
5905         if (itype(i).eq.ntyp1) cycle
5906         costtab(i+1) =dcos(theta(i+1))
5907         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5908         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5909         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5910         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5911         cosfac=dsqrt(cosfac2)
5912         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5913         sinfac=dsqrt(sinfac2)
5914         it=iabs(itype(i))
5915         if (it.eq.10) goto 1
5916 c
5917 C  Compute the axes of tghe local cartesian coordinates system; store in
5918 c   x_prime, y_prime and z_prime
5919 c
5920         do j=1,3
5921           x_prime(j) = 0.00
5922           y_prime(j) = 0.00
5923           z_prime(j) = 0.00
5924         enddo
5925 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5926 C     &   dc_norm(3,i+nres)
5927         do j = 1,3
5928           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5929           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5930         enddo
5931         do j = 1,3
5932           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5933         enddo
5934 c       write (2,*) "i",i
5935 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5936 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5937 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5938 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5939 c      & " xy",scalar(x_prime(1),y_prime(1)),
5940 c      & " xz",scalar(x_prime(1),z_prime(1)),
5941 c      & " yy",scalar(y_prime(1),y_prime(1)),
5942 c      & " yz",scalar(y_prime(1),z_prime(1)),
5943 c      & " zz",scalar(z_prime(1),z_prime(1))
5944 c
5945 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5946 C to local coordinate system. Store in xx, yy, zz.
5947 c
5948         xx=0.0d0
5949         yy=0.0d0
5950         zz=0.0d0
5951         do j = 1,3
5952           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5953           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5954           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5955         enddo
5956
5957         xxtab(i)=xx
5958         yytab(i)=yy
5959         zztab(i)=zz
5960 C
5961 C Compute the energy of the ith side cbain
5962 C
5963 c        write (2,*) "xx",xx," yy",yy," zz",zz
5964         it=iabs(itype(i))
5965         do j = 1,65
5966           x(j) = sc_parmin(j,it)
5967         enddo
5968 #ifdef CHECK_COORD
5969 Cc diagnostics - remove later
5970         xx1 = dcos(alph(2))
5971         yy1 = dsin(alph(2))*dcos(omeg(2))
5972         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5973         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5974      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5975      &    xx1,yy1,zz1
5976 C,"  --- ", xx_w,yy_w,zz_w
5977 c end diagnostics
5978 #endif
5979         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5980      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5981      &   + x(10)*yy*zz
5982         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5983      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5984      & + x(20)*yy*zz
5985         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5986      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5987      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5988      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5989      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5990      &  +x(40)*xx*yy*zz
5991         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5992      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5993      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5994      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5995      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5996      &  +x(60)*xx*yy*zz
5997         dsc_i   = 0.743d0+x(61)
5998         dp2_i   = 1.9d0+x(62)
5999         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6000      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6001         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6002      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6003         s1=(1+x(63))/(0.1d0 + dscp1)
6004         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6005         s2=(1+x(65))/(0.1d0 + dscp2)
6006         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6007         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6008      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6009 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6010 c     &   sumene4,
6011 c     &   dscp1,dscp2,sumene
6012 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6013         escloc = escloc + sumene
6014 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6015 c     & ,zz,xx,yy
6016 c#define DEBUG
6017 #ifdef DEBUG
6018 C
6019 C This section to check the numerical derivatives of the energy of ith side
6020 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6021 C #define DEBUG in the code to turn it on.
6022 C
6023         write (2,*) "sumene               =",sumene
6024         aincr=1.0d-7
6025         xxsave=xx
6026         xx=xx+aincr
6027         write (2,*) xx,yy,zz
6028         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6029         de_dxx_num=(sumenep-sumene)/aincr
6030         xx=xxsave
6031         write (2,*) "xx+ sumene from enesc=",sumenep
6032         yysave=yy
6033         yy=yy+aincr
6034         write (2,*) xx,yy,zz
6035         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6036         de_dyy_num=(sumenep-sumene)/aincr
6037         yy=yysave
6038         write (2,*) "yy+ sumene from enesc=",sumenep
6039         zzsave=zz
6040         zz=zz+aincr
6041         write (2,*) xx,yy,zz
6042         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6043         de_dzz_num=(sumenep-sumene)/aincr
6044         zz=zzsave
6045         write (2,*) "zz+ sumene from enesc=",sumenep
6046         costsave=cost2tab(i+1)
6047         sintsave=sint2tab(i+1)
6048         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6049         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6050         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6051         de_dt_num=(sumenep-sumene)/aincr
6052         write (2,*) " t+ sumene from enesc=",sumenep
6053         cost2tab(i+1)=costsave
6054         sint2tab(i+1)=sintsave
6055 C End of diagnostics section.
6056 #endif
6057 C
6058 C Compute the gradient of esc
6059 C
6060 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6061         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6062         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6063         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6064         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6065         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6066         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6067         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6068         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6069         pom1=(sumene3*sint2tab(i+1)+sumene1)
6070      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6071         pom2=(sumene4*cost2tab(i+1)+sumene2)
6072      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6073         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6074         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6075      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6076      &  +x(40)*yy*zz
6077         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6078         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6079      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6080      &  +x(60)*yy*zz
6081         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6082      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6083      &        +(pom1+pom2)*pom_dx
6084 #ifdef DEBUG
6085         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6086 #endif
6087 C
6088         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6089         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6090      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6091      &  +x(40)*xx*zz
6092         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6093         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6094      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6095      &  +x(59)*zz**2 +x(60)*xx*zz
6096         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6097      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6098      &        +(pom1-pom2)*pom_dy
6099 #ifdef DEBUG
6100         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6101 #endif
6102 C
6103         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6104      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6105      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6106      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6107      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6108      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6109      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6110      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6111 #ifdef DEBUG
6112         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6113 #endif
6114 C
6115         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6116      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6117      &  +pom1*pom_dt1+pom2*pom_dt2
6118 #ifdef DEBUG
6119         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6120 #endif
6121 c#undef DEBUG
6122 c
6123 C
6124        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6125        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6126        cosfac2xx=cosfac2*xx
6127        sinfac2yy=sinfac2*yy
6128        do k = 1,3
6129          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6130      &      vbld_inv(i+1)
6131          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6132      &      vbld_inv(i)
6133          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6134          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6135 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6136 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6137 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6138 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6139          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6140          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6141          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6142          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6143          dZZ_Ci1(k)=0.0d0
6144          dZZ_Ci(k)=0.0d0
6145          do j=1,3
6146            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6147      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6148            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6149      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6150          enddo
6151
6152          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6153          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6154          dZZ_XYZ(k)=vbld_inv(i+nres)*
6155      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6156 c
6157          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6158          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6159        enddo
6160
6161        do k=1,3
6162          dXX_Ctab(k,i)=dXX_Ci(k)
6163          dXX_C1tab(k,i)=dXX_Ci1(k)
6164          dYY_Ctab(k,i)=dYY_Ci(k)
6165          dYY_C1tab(k,i)=dYY_Ci1(k)
6166          dZZ_Ctab(k,i)=dZZ_Ci(k)
6167          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6168          dXX_XYZtab(k,i)=dXX_XYZ(k)
6169          dYY_XYZtab(k,i)=dYY_XYZ(k)
6170          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6171        enddo
6172
6173        do k = 1,3
6174 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6175 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6176 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6177 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6178 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6179 c     &    dt_dci(k)
6180 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6181 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6182          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6183      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6184          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6185      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6186          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6187      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6188        enddo
6189 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6190 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6191
6192 C to check gradient call subroutine check_grad
6193
6194     1 continue
6195       enddo
6196       return
6197       end
6198 c------------------------------------------------------------------------------
6199       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6200       implicit none
6201       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6202      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6203       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6204      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6205      &   + x(10)*yy*zz
6206       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6207      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6208      & + x(20)*yy*zz
6209       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6210      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6211      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6212      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6213      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6214      &  +x(40)*xx*yy*zz
6215       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6216      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6217      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6218      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6219      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6220      &  +x(60)*xx*yy*zz
6221       dsc_i   = 0.743d0+x(61)
6222       dp2_i   = 1.9d0+x(62)
6223       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6224      &          *(xx*cost2+yy*sint2))
6225       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6226      &          *(xx*cost2-yy*sint2))
6227       s1=(1+x(63))/(0.1d0 + dscp1)
6228       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6229       s2=(1+x(65))/(0.1d0 + dscp2)
6230       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6231       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6232      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6233       enesc=sumene
6234       return
6235       end
6236 #endif
6237 c------------------------------------------------------------------------------
6238       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6239 C
6240 C This procedure calculates two-body contact function g(rij) and its derivative:
6241 C
6242 C           eps0ij                                     !       x < -1
6243 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6244 C            0                                         !       x > 1
6245 C
6246 C where x=(rij-r0ij)/delta
6247 C
6248 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6249 C
6250       implicit none
6251       double precision rij,r0ij,eps0ij,fcont,fprimcont
6252       double precision x,x2,x4,delta
6253 c     delta=0.02D0*r0ij
6254 c      delta=0.2D0*r0ij
6255       x=(rij-r0ij)/delta
6256       if (x.lt.-1.0D0) then
6257         fcont=eps0ij
6258         fprimcont=0.0D0
6259       else if (x.le.1.0D0) then
6260         x2=x*x
6261         x4=x2*x2
6262         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6263         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6264       else
6265         fcont=0.0D0
6266         fprimcont=0.0D0
6267       endif
6268       return
6269       end
6270 c------------------------------------------------------------------------------
6271       subroutine splinthet(theti,delta,ss,ssder)
6272       implicit real*8 (a-h,o-z)
6273       include 'DIMENSIONS'
6274       include 'COMMON.VAR'
6275       include 'COMMON.GEO'
6276       thetup=pi-delta
6277       thetlow=delta
6278       if (theti.gt.pipol) then
6279         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6280       else
6281         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6282         ssder=-ssder
6283       endif
6284       return
6285       end
6286 c------------------------------------------------------------------------------
6287       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6288       implicit none
6289       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6290       double precision ksi,ksi2,ksi3,a1,a2,a3
6291       a1=fprim0*delta/(f1-f0)
6292       a2=3.0d0-2.0d0*a1
6293       a3=a1-2.0d0
6294       ksi=(x-x0)/delta
6295       ksi2=ksi*ksi
6296       ksi3=ksi2*ksi
6297       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6298       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6299       return
6300       end
6301 c------------------------------------------------------------------------------
6302       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6303       implicit none
6304       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6305       double precision ksi,ksi2,ksi3,a1,a2,a3
6306       ksi=(x-x0)/delta
6307       ksi2=ksi*ksi
6308       ksi3=ksi2*ksi
6309       a1=fprim0x*delta
6310       a2=3*(f1x-f0x)-2*fprim0x*delta
6311       a3=fprim0x*delta-2*(f1x-f0x)
6312       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6313       return
6314       end
6315 C-----------------------------------------------------------------------------
6316 #ifdef CRYST_TOR
6317 C-----------------------------------------------------------------------------
6318       subroutine etor(etors,edihcnstr)
6319       implicit real*8 (a-h,o-z)
6320       include 'DIMENSIONS'
6321       include 'COMMON.VAR'
6322       include 'COMMON.GEO'
6323       include 'COMMON.LOCAL'
6324       include 'COMMON.TORSION'
6325       include 'COMMON.INTERACT'
6326       include 'COMMON.DERIV'
6327       include 'COMMON.CHAIN'
6328       include 'COMMON.NAMES'
6329       include 'COMMON.IOUNITS'
6330       include 'COMMON.FFIELD'
6331       include 'COMMON.TORCNSTR'
6332       include 'COMMON.CONTROL'
6333       logical lprn
6334 C Set lprn=.true. for debugging
6335       lprn=.false.
6336 c      lprn=.true.
6337       etors=0.0D0
6338       do i=iphi_start,iphi_end
6339       etors_ii=0.0D0
6340         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6341      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6342         itori=itortyp(itype(i-2))
6343         itori1=itortyp(itype(i-1))
6344         phii=phi(i)
6345         gloci=0.0D0
6346 C Proline-Proline pair is a special case...
6347         if (itori.eq.3 .and. itori1.eq.3) then
6348           if (phii.gt.-dwapi3) then
6349             cosphi=dcos(3*phii)
6350             fac=1.0D0/(1.0D0-cosphi)
6351             etorsi=v1(1,3,3)*fac
6352             etorsi=etorsi+etorsi
6353             etors=etors+etorsi-v1(1,3,3)
6354             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6355             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6356           endif
6357           do j=1,3
6358             v1ij=v1(j+1,itori,itori1)
6359             v2ij=v2(j+1,itori,itori1)
6360             cosphi=dcos(j*phii)
6361             sinphi=dsin(j*phii)
6362             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6363             if (energy_dec) etors_ii=etors_ii+
6364      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6365             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6366           enddo
6367         else
6368           do j=1,nterm_old
6369             v1ij=v1(j,itori,itori1)
6370             v2ij=v2(j,itori,itori1)
6371             cosphi=dcos(j*phii)
6372             sinphi=dsin(j*phii)
6373             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6374             if (energy_dec) etors_ii=etors_ii+
6375      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6376             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6377           enddo
6378         endif
6379         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6380              'etor',i,etors_ii
6381         if (lprn)
6382      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6383      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6384      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6385         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6386 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6387       enddo
6388 ! 6/20/98 - dihedral angle constraints
6389       edihcnstr=0.0d0
6390       do i=1,ndih_constr
6391         itori=idih_constr(i)
6392         phii=phi(itori)
6393         difi=phii-phi0(i)
6394         if (difi.gt.drange(i)) then
6395           difi=difi-drange(i)
6396           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6397           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6398         else if (difi.lt.-drange(i)) then
6399           difi=difi+drange(i)
6400           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6401           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6402         endif
6403 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6404 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6405       enddo
6406 !      write (iout,*) 'edihcnstr',edihcnstr
6407       return
6408       end
6409 c------------------------------------------------------------------------------
6410       subroutine etor_d(etors_d)
6411       etors_d=0.0d0
6412       return
6413       end
6414 c----------------------------------------------------------------------------
6415 #else
6416       subroutine etor(etors,edihcnstr)
6417       implicit real*8 (a-h,o-z)
6418       include 'DIMENSIONS'
6419       include 'COMMON.VAR'
6420       include 'COMMON.GEO'
6421       include 'COMMON.LOCAL'
6422       include 'COMMON.TORSION'
6423       include 'COMMON.INTERACT'
6424       include 'COMMON.DERIV'
6425       include 'COMMON.CHAIN'
6426       include 'COMMON.NAMES'
6427       include 'COMMON.IOUNITS'
6428       include 'COMMON.FFIELD'
6429       include 'COMMON.TORCNSTR'
6430       include 'COMMON.CONTROL'
6431       logical lprn
6432 C Set lprn=.true. for debugging
6433       lprn=.false.
6434 c     lprn=.true.
6435       etors=0.0D0
6436       do i=iphi_start,iphi_end
6437 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6438 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6439 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6440 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6441         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6442      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6443 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6444 C For introducing the NH3+ and COO- group please check the etor_d for reference
6445 C and guidance
6446         etors_ii=0.0D0
6447          if (iabs(itype(i)).eq.20) then
6448          iblock=2
6449          else
6450          iblock=1
6451          endif
6452         itori=itortyp(itype(i-2))
6453         itori1=itortyp(itype(i-1))
6454         phii=phi(i)
6455         gloci=0.0D0
6456 C Regular cosine and sine terms
6457         do j=1,nterm(itori,itori1,iblock)
6458           v1ij=v1(j,itori,itori1,iblock)
6459           v2ij=v2(j,itori,itori1,iblock)
6460           cosphi=dcos(j*phii)
6461           sinphi=dsin(j*phii)
6462           etors=etors+v1ij*cosphi+v2ij*sinphi
6463           if (energy_dec) etors_ii=etors_ii+
6464      &                v1ij*cosphi+v2ij*sinphi
6465           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6466         enddo
6467 C Lorentz terms
6468 C                         v1
6469 C  E = SUM ----------------------------------- - v1
6470 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6471 C
6472         cosphi=dcos(0.5d0*phii)
6473         sinphi=dsin(0.5d0*phii)
6474         do j=1,nlor(itori,itori1,iblock)
6475           vl1ij=vlor1(j,itori,itori1)
6476           vl2ij=vlor2(j,itori,itori1)
6477           vl3ij=vlor3(j,itori,itori1)
6478           pom=vl2ij*cosphi+vl3ij*sinphi
6479           pom1=1.0d0/(pom*pom+1.0d0)
6480           etors=etors+vl1ij*pom1
6481           if (energy_dec) etors_ii=etors_ii+
6482      &                vl1ij*pom1
6483           pom=-pom*pom1*pom1
6484           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6485         enddo
6486 C Subtract the constant term
6487         etors=etors-v0(itori,itori1,iblock)
6488           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6489      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6490         if (lprn)
6491      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6492      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6493      &  (v1(j,itori,itori1,iblock),j=1,6),
6494      &  (v2(j,itori,itori1,iblock),j=1,6)
6495         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6496 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6497       enddo
6498 ! 6/20/98 - dihedral angle constraints
6499       edihcnstr=0.0d0
6500 c      do i=1,ndih_constr
6501       do i=idihconstr_start,idihconstr_end
6502         itori=idih_constr(i)
6503         phii=phi(itori)
6504         difi=pinorm(phii-phi0(i))
6505         if (difi.gt.drange(i)) then
6506           difi=difi-drange(i)
6507           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6508           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6509         else if (difi.lt.-drange(i)) then
6510           difi=difi+drange(i)
6511           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6512           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6513         else
6514           difi=0.0
6515         endif
6516 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6517 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6518 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6519       enddo
6520 cd       write (iout,*) 'edihcnstr',edihcnstr
6521       return
6522       end
6523 c----------------------------------------------------------------------------
6524       subroutine etor_d(etors_d)
6525 C 6/23/01 Compute double torsional energy
6526       implicit real*8 (a-h,o-z)
6527       include 'DIMENSIONS'
6528       include 'COMMON.VAR'
6529       include 'COMMON.GEO'
6530       include 'COMMON.LOCAL'
6531       include 'COMMON.TORSION'
6532       include 'COMMON.INTERACT'
6533       include 'COMMON.DERIV'
6534       include 'COMMON.CHAIN'
6535       include 'COMMON.NAMES'
6536       include 'COMMON.IOUNITS'
6537       include 'COMMON.FFIELD'
6538       include 'COMMON.TORCNSTR'
6539       logical lprn
6540 C Set lprn=.true. for debugging
6541       lprn=.false.
6542 c     lprn=.true.
6543       etors_d=0.0D0
6544 c      write(iout,*) "a tu??"
6545       do i=iphid_start,iphid_end
6546 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6547 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6548 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6549 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6550 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6551          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6552      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6553      &  (itype(i+1).eq.ntyp1)) cycle
6554 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6555         itori=itortyp(itype(i-2))
6556         itori1=itortyp(itype(i-1))
6557         itori2=itortyp(itype(i))
6558         phii=phi(i)
6559         phii1=phi(i+1)
6560         gloci1=0.0D0
6561         gloci2=0.0D0
6562         iblock=1
6563         if (iabs(itype(i+1)).eq.20) iblock=2
6564 C Iblock=2 Proline type
6565 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6566 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6567 C        if (itype(i+1).eq.ntyp1) iblock=3
6568 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6569 C IS or IS NOT need for this
6570 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6571 C        is (itype(i-3).eq.ntyp1) ntblock=2
6572 C        ntblock is N-terminal blocking group
6573
6574 C Regular cosine and sine terms
6575         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6576 C Example of changes for NH3+ blocking group
6577 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6578 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6579           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6580           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6581           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6582           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6583           cosphi1=dcos(j*phii)
6584           sinphi1=dsin(j*phii)
6585           cosphi2=dcos(j*phii1)
6586           sinphi2=dsin(j*phii1)
6587           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6588      &     v2cij*cosphi2+v2sij*sinphi2
6589           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6590           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6591         enddo
6592         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6593           do l=1,k-1
6594             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6595             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6596             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6597             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6598             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6599             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6600             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6601             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6602             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6603      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6604             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6605      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6606             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6607      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6608           enddo
6609         enddo
6610         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6611         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6612       enddo
6613       return
6614       end
6615 #endif
6616 c------------------------------------------------------------------------------
6617       subroutine eback_sc_corr(esccor)
6618 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6619 c        conformational states; temporarily implemented as differences
6620 c        between UNRES torsional potentials (dependent on three types of
6621 c        residues) and the torsional potentials dependent on all 20 types
6622 c        of residues computed from AM1  energy surfaces of terminally-blocked
6623 c        amino-acid residues.
6624       implicit real*8 (a-h,o-z)
6625       include 'DIMENSIONS'
6626       include 'COMMON.VAR'
6627       include 'COMMON.GEO'
6628       include 'COMMON.LOCAL'
6629       include 'COMMON.TORSION'
6630       include 'COMMON.SCCOR'
6631       include 'COMMON.INTERACT'
6632       include 'COMMON.DERIV'
6633       include 'COMMON.CHAIN'
6634       include 'COMMON.NAMES'
6635       include 'COMMON.IOUNITS'
6636       include 'COMMON.FFIELD'
6637       include 'COMMON.CONTROL'
6638       logical lprn
6639 C Set lprn=.true. for debugging
6640       lprn=.false.
6641 c      lprn=.true.
6642 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6643       esccor=0.0D0
6644       do i=itau_start,itau_end
6645         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6646         esccor_ii=0.0D0
6647         isccori=isccortyp(itype(i-2))
6648         isccori1=isccortyp(itype(i-1))
6649 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6650         phii=phi(i)
6651         do intertyp=1,3 !intertyp
6652 cc Added 09 May 2012 (Adasko)
6653 cc  Intertyp means interaction type of backbone mainchain correlation:
6654 c   1 = SC...Ca...Ca...Ca
6655 c   2 = Ca...Ca...Ca...SC
6656 c   3 = SC...Ca...Ca...SCi
6657         gloci=0.0D0
6658         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6659      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6660      &      (itype(i-1).eq.ntyp1)))
6661      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6662      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6663      &     .or.(itype(i).eq.ntyp1)))
6664      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6665      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6666      &      (itype(i-3).eq.ntyp1)))) cycle
6667         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6668         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6669      & cycle
6670        do j=1,nterm_sccor(isccori,isccori1)
6671           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6672           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6673           cosphi=dcos(j*tauangle(intertyp,i))
6674           sinphi=dsin(j*tauangle(intertyp,i))
6675           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6676           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6677         enddo
6678 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6679         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6680         if (lprn)
6681      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6682      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6683      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6684      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6685         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6686        enddo !intertyp
6687       enddo
6688
6689       return
6690       end
6691 c----------------------------------------------------------------------------
6692       subroutine multibody(ecorr)
6693 C This subroutine calculates multi-body contributions to energy following
6694 C the idea of Skolnick et al. If side chains I and J make a contact and
6695 C at the same time side chains I+1 and J+1 make a contact, an extra
6696 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6697       implicit real*8 (a-h,o-z)
6698       include 'DIMENSIONS'
6699       include 'COMMON.IOUNITS'
6700       include 'COMMON.DERIV'
6701       include 'COMMON.INTERACT'
6702       include 'COMMON.CONTACTS'
6703       double precision gx(3),gx1(3)
6704       logical lprn
6705
6706 C Set lprn=.true. for debugging
6707       lprn=.false.
6708
6709       if (lprn) then
6710         write (iout,'(a)') 'Contact function values:'
6711         do i=nnt,nct-2
6712           write (iout,'(i2,20(1x,i2,f10.5))')
6713      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6714         enddo
6715       endif
6716       ecorr=0.0D0
6717       do i=nnt,nct
6718         do j=1,3
6719           gradcorr(j,i)=0.0D0
6720           gradxorr(j,i)=0.0D0
6721         enddo
6722       enddo
6723       do i=nnt,nct-2
6724
6725         DO ISHIFT = 3,4
6726
6727         i1=i+ishift
6728         num_conti=num_cont(i)
6729         num_conti1=num_cont(i1)
6730         do jj=1,num_conti
6731           j=jcont(jj,i)
6732           do kk=1,num_conti1
6733             j1=jcont(kk,i1)
6734             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6735 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6736 cd   &                   ' ishift=',ishift
6737 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6738 C The system gains extra energy.
6739               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6740             endif   ! j1==j+-ishift
6741           enddo     ! kk
6742         enddo       ! jj
6743
6744         ENDDO ! ISHIFT
6745
6746       enddo         ! i
6747       return
6748       end
6749 c------------------------------------------------------------------------------
6750       double precision function esccorr(i,j,k,l,jj,kk)
6751       implicit real*8 (a-h,o-z)
6752       include 'DIMENSIONS'
6753       include 'COMMON.IOUNITS'
6754       include 'COMMON.DERIV'
6755       include 'COMMON.INTERACT'
6756       include 'COMMON.CONTACTS'
6757       double precision gx(3),gx1(3)
6758       logical lprn
6759       lprn=.false.
6760       eij=facont(jj,i)
6761       ekl=facont(kk,k)
6762 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6763 C Calculate the multi-body contribution to energy.
6764 C Calculate multi-body contributions to the gradient.
6765 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6766 cd   & k,l,(gacont(m,kk,k),m=1,3)
6767       do m=1,3
6768         gx(m) =ekl*gacont(m,jj,i)
6769         gx1(m)=eij*gacont(m,kk,k)
6770         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6771         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6772         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6773         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6774       enddo
6775       do m=i,j-1
6776         do ll=1,3
6777           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6778         enddo
6779       enddo
6780       do m=k,l-1
6781         do ll=1,3
6782           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6783         enddo
6784       enddo
6785       esccorr=-eij*ekl
6786       return
6787       end
6788 c------------------------------------------------------------------------------
6789       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6790 C This subroutine calculates multi-body contributions to hydrogen-bonding
6791       implicit real*8 (a-h,o-z)
6792       include 'DIMENSIONS'
6793       include 'COMMON.IOUNITS'
6794 #ifdef MPI
6795       include "mpif.h"
6796       parameter (max_cont=maxconts)
6797       parameter (max_dim=26)
6798       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6799       double precision zapas(max_dim,maxconts,max_fg_procs),
6800      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6801       common /przechowalnia/ zapas
6802       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6803      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6804 #endif
6805       include 'COMMON.SETUP'
6806       include 'COMMON.FFIELD'
6807       include 'COMMON.DERIV'
6808       include 'COMMON.INTERACT'
6809       include 'COMMON.CONTACTS'
6810       include 'COMMON.CONTROL'
6811       include 'COMMON.LOCAL'
6812       double precision gx(3),gx1(3),time00
6813       logical lprn,ldone
6814
6815 C Set lprn=.true. for debugging
6816       lprn=.false.
6817 #ifdef MPI
6818       n_corr=0
6819       n_corr1=0
6820       if (nfgtasks.le.1) goto 30
6821       if (lprn) then
6822         write (iout,'(a)') 'Contact function values before RECEIVE:'
6823         do i=nnt,nct-2
6824           write (iout,'(2i3,50(1x,i2,f5.2))')
6825      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6826      &    j=1,num_cont_hb(i))
6827         enddo
6828       endif
6829       call flush(iout)
6830       do i=1,ntask_cont_from
6831         ncont_recv(i)=0
6832       enddo
6833       do i=1,ntask_cont_to
6834         ncont_sent(i)=0
6835       enddo
6836 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6837 c     & ntask_cont_to
6838 C Make the list of contacts to send to send to other procesors
6839 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6840 c      call flush(iout)
6841       do i=iturn3_start,iturn3_end
6842 c        write (iout,*) "make contact list turn3",i," num_cont",
6843 c     &    num_cont_hb(i)
6844         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6845       enddo
6846       do i=iturn4_start,iturn4_end
6847 c        write (iout,*) "make contact list turn4",i," num_cont",
6848 c     &   num_cont_hb(i)
6849         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6850       enddo
6851       do ii=1,nat_sent
6852         i=iat_sent(ii)
6853 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6854 c     &    num_cont_hb(i)
6855         do j=1,num_cont_hb(i)
6856         do k=1,4
6857           jjc=jcont_hb(j,i)
6858           iproc=iint_sent_local(k,jjc,ii)
6859 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6860           if (iproc.gt.0) then
6861             ncont_sent(iproc)=ncont_sent(iproc)+1
6862             nn=ncont_sent(iproc)
6863             zapas(1,nn,iproc)=i
6864             zapas(2,nn,iproc)=jjc
6865             zapas(3,nn,iproc)=facont_hb(j,i)
6866             zapas(4,nn,iproc)=ees0p(j,i)
6867             zapas(5,nn,iproc)=ees0m(j,i)
6868             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6869             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6870             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6871             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6872             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6873             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6874             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6875             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6876             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6877             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6878             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6879             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6880             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6881             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6882             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6883             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6884             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6885             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6886             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6887             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6888             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6889           endif
6890         enddo
6891         enddo
6892       enddo
6893       if (lprn) then
6894       write (iout,*)
6895      &  "Numbers of contacts to be sent to other processors",
6896      &  (ncont_sent(i),i=1,ntask_cont_to)
6897       write (iout,*) "Contacts sent"
6898       do ii=1,ntask_cont_to
6899         nn=ncont_sent(ii)
6900         iproc=itask_cont_to(ii)
6901         write (iout,*) nn," contacts to processor",iproc,
6902      &   " of CONT_TO_COMM group"
6903         do i=1,nn
6904           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6905         enddo
6906       enddo
6907       call flush(iout)
6908       endif
6909       CorrelType=477
6910       CorrelID=fg_rank+1
6911       CorrelType1=478
6912       CorrelID1=nfgtasks+fg_rank+1
6913       ireq=0
6914 C Receive the numbers of needed contacts from other processors
6915       do ii=1,ntask_cont_from
6916         iproc=itask_cont_from(ii)
6917         ireq=ireq+1
6918         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6919      &    FG_COMM,req(ireq),IERR)
6920       enddo
6921 c      write (iout,*) "IRECV ended"
6922 c      call flush(iout)
6923 C Send the number of contacts needed by other processors
6924       do ii=1,ntask_cont_to
6925         iproc=itask_cont_to(ii)
6926         ireq=ireq+1
6927         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6928      &    FG_COMM,req(ireq),IERR)
6929       enddo
6930 c      write (iout,*) "ISEND ended"
6931 c      write (iout,*) "number of requests (nn)",ireq
6932       call flush(iout)
6933       if (ireq.gt.0)
6934      &  call MPI_Waitall(ireq,req,status_array,ierr)
6935 c      write (iout,*)
6936 c     &  "Numbers of contacts to be received from other processors",
6937 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6938 c      call flush(iout)
6939 C Receive contacts
6940       ireq=0
6941       do ii=1,ntask_cont_from
6942         iproc=itask_cont_from(ii)
6943         nn=ncont_recv(ii)
6944 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6945 c     &   " of CONT_TO_COMM group"
6946         call flush(iout)
6947         if (nn.gt.0) then
6948           ireq=ireq+1
6949           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6950      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6951 c          write (iout,*) "ireq,req",ireq,req(ireq)
6952         endif
6953       enddo
6954 C Send the contacts to processors that need them
6955       do ii=1,ntask_cont_to
6956         iproc=itask_cont_to(ii)
6957         nn=ncont_sent(ii)
6958 c        write (iout,*) nn," contacts to processor",iproc,
6959 c     &   " of CONT_TO_COMM group"
6960         if (nn.gt.0) then
6961           ireq=ireq+1
6962           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6963      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6964 c          write (iout,*) "ireq,req",ireq,req(ireq)
6965 c          do i=1,nn
6966 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6967 c          enddo
6968         endif
6969       enddo
6970 c      write (iout,*) "number of requests (contacts)",ireq
6971 c      write (iout,*) "req",(req(i),i=1,4)
6972 c      call flush(iout)
6973       if (ireq.gt.0)
6974      & call MPI_Waitall(ireq,req,status_array,ierr)
6975       do iii=1,ntask_cont_from
6976         iproc=itask_cont_from(iii)
6977         nn=ncont_recv(iii)
6978         if (lprn) then
6979         write (iout,*) "Received",nn," contacts from processor",iproc,
6980      &   " of CONT_FROM_COMM group"
6981         call flush(iout)
6982         do i=1,nn
6983           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6984         enddo
6985         call flush(iout)
6986         endif
6987         do i=1,nn
6988           ii=zapas_recv(1,i,iii)
6989 c Flag the received contacts to prevent double-counting
6990           jj=-zapas_recv(2,i,iii)
6991 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6992 c          call flush(iout)
6993           nnn=num_cont_hb(ii)+1
6994           num_cont_hb(ii)=nnn
6995           jcont_hb(nnn,ii)=jj
6996           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6997           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6998           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6999           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7000           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7001           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7002           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7003           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7004           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7005           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7006           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7007           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7008           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7009           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7010           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7011           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7012           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7013           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7014           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7015           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7016           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7017           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7018           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7019           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7020         enddo
7021       enddo
7022       call flush(iout)
7023       if (lprn) then
7024         write (iout,'(a)') 'Contact function values after receive:'
7025         do i=nnt,nct-2
7026           write (iout,'(2i3,50(1x,i3,f5.2))')
7027      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7028      &    j=1,num_cont_hb(i))
7029         enddo
7030         call flush(iout)
7031       endif
7032    30 continue
7033 #endif
7034       if (lprn) then
7035         write (iout,'(a)') 'Contact function values:'
7036         do i=nnt,nct-2
7037           write (iout,'(2i3,50(1x,i3,f5.2))')
7038      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7039      &    j=1,num_cont_hb(i))
7040         enddo
7041       endif
7042       ecorr=0.0D0
7043 C Remove the loop below after debugging !!!
7044       do i=nnt,nct
7045         do j=1,3
7046           gradcorr(j,i)=0.0D0
7047           gradxorr(j,i)=0.0D0
7048         enddo
7049       enddo
7050 C Calculate the local-electrostatic correlation terms
7051       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7052         i1=i+1
7053         num_conti=num_cont_hb(i)
7054         num_conti1=num_cont_hb(i+1)
7055         do jj=1,num_conti
7056           j=jcont_hb(jj,i)
7057           jp=iabs(j)
7058           do kk=1,num_conti1
7059             j1=jcont_hb(kk,i1)
7060             jp1=iabs(j1)
7061 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7062 c     &         ' jj=',jj,' kk=',kk
7063             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7064      &          .or. j.lt.0 .and. j1.gt.0) .and.
7065      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7066 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7067 C The system gains extra energy.
7068               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7069               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7070      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7071               n_corr=n_corr+1
7072             else if (j1.eq.j) then
7073 C Contacts I-J and I-(J+1) occur simultaneously.
7074 C The system loses extra energy.
7075 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7076             endif
7077           enddo ! kk
7078           do kk=1,num_conti
7079             j1=jcont_hb(kk,i)
7080 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7081 c    &         ' jj=',jj,' kk=',kk
7082             if (j1.eq.j+1) then
7083 C Contacts I-J and (I+1)-J occur simultaneously.
7084 C The system loses extra energy.
7085 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7086             endif ! j1==j+1
7087           enddo ! kk
7088         enddo ! jj
7089       enddo ! i
7090       return
7091       end
7092 c------------------------------------------------------------------------------
7093       subroutine add_hb_contact(ii,jj,itask)
7094       implicit real*8 (a-h,o-z)
7095       include "DIMENSIONS"
7096       include "COMMON.IOUNITS"
7097       integer max_cont
7098       integer max_dim
7099       parameter (max_cont=maxconts)
7100       parameter (max_dim=26)
7101       include "COMMON.CONTACTS"
7102       double precision zapas(max_dim,maxconts,max_fg_procs),
7103      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7104       common /przechowalnia/ zapas
7105       integer i,j,ii,jj,iproc,itask(4),nn
7106 c      write (iout,*) "itask",itask
7107       do i=1,2
7108         iproc=itask(i)
7109         if (iproc.gt.0) then
7110           do j=1,num_cont_hb(ii)
7111             jjc=jcont_hb(j,ii)
7112 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7113             if (jjc.eq.jj) then
7114               ncont_sent(iproc)=ncont_sent(iproc)+1
7115               nn=ncont_sent(iproc)
7116               zapas(1,nn,iproc)=ii
7117               zapas(2,nn,iproc)=jjc
7118               zapas(3,nn,iproc)=facont_hb(j,ii)
7119               zapas(4,nn,iproc)=ees0p(j,ii)
7120               zapas(5,nn,iproc)=ees0m(j,ii)
7121               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7122               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7123               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7124               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7125               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7126               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7127               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7128               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7129               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7130               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7131               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7132               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7133               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7134               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7135               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7136               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7137               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7138               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7139               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7140               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7141               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7142               exit
7143             endif
7144           enddo
7145         endif
7146       enddo
7147       return
7148       end
7149 c------------------------------------------------------------------------------
7150       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7151      &  n_corr1)
7152 C This subroutine calculates multi-body contributions to hydrogen-bonding
7153       implicit real*8 (a-h,o-z)
7154       include 'DIMENSIONS'
7155       include 'COMMON.IOUNITS'
7156 #ifdef MPI
7157       include "mpif.h"
7158       parameter (max_cont=maxconts)
7159       parameter (max_dim=70)
7160       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7161       double precision zapas(max_dim,maxconts,max_fg_procs),
7162      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7163       common /przechowalnia/ zapas
7164       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7165      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7166 #endif
7167       include 'COMMON.SETUP'
7168       include 'COMMON.FFIELD'
7169       include 'COMMON.DERIV'
7170       include 'COMMON.LOCAL'
7171       include 'COMMON.INTERACT'
7172       include 'COMMON.CONTACTS'
7173       include 'COMMON.CHAIN'
7174       include 'COMMON.CONTROL'
7175       double precision gx(3),gx1(3)
7176       integer num_cont_hb_old(maxres)
7177       logical lprn,ldone
7178       double precision eello4,eello5,eelo6,eello_turn6
7179       external eello4,eello5,eello6,eello_turn6
7180 C Set lprn=.true. for debugging
7181       lprn=.false.
7182       eturn6=0.0d0
7183 #ifdef MPI
7184       do i=1,nres
7185         num_cont_hb_old(i)=num_cont_hb(i)
7186       enddo
7187       n_corr=0
7188       n_corr1=0
7189       if (nfgtasks.le.1) goto 30
7190       if (lprn) then
7191         write (iout,'(a)') 'Contact function values before RECEIVE:'
7192         do i=nnt,nct-2
7193           write (iout,'(2i3,50(1x,i2,f5.2))')
7194      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7195      &    j=1,num_cont_hb(i))
7196         enddo
7197       endif
7198       call flush(iout)
7199       do i=1,ntask_cont_from
7200         ncont_recv(i)=0
7201       enddo
7202       do i=1,ntask_cont_to
7203         ncont_sent(i)=0
7204       enddo
7205 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7206 c     & ntask_cont_to
7207 C Make the list of contacts to send to send to other procesors
7208       do i=iturn3_start,iturn3_end
7209 c        write (iout,*) "make contact list turn3",i," num_cont",
7210 c     &    num_cont_hb(i)
7211         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7212       enddo
7213       do i=iturn4_start,iturn4_end
7214 c        write (iout,*) "make contact list turn4",i," num_cont",
7215 c     &   num_cont_hb(i)
7216         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7217       enddo
7218       do ii=1,nat_sent
7219         i=iat_sent(ii)
7220 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7221 c     &    num_cont_hb(i)
7222         do j=1,num_cont_hb(i)
7223         do k=1,4
7224           jjc=jcont_hb(j,i)
7225           iproc=iint_sent_local(k,jjc,ii)
7226 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7227           if (iproc.ne.0) then
7228             ncont_sent(iproc)=ncont_sent(iproc)+1
7229             nn=ncont_sent(iproc)
7230             zapas(1,nn,iproc)=i
7231             zapas(2,nn,iproc)=jjc
7232             zapas(3,nn,iproc)=d_cont(j,i)
7233             ind=3
7234             do kk=1,3
7235               ind=ind+1
7236               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7237             enddo
7238             do kk=1,2
7239               do ll=1,2
7240                 ind=ind+1
7241                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7242               enddo
7243             enddo
7244             do jj=1,5
7245               do kk=1,3
7246                 do ll=1,2
7247                   do mm=1,2
7248                     ind=ind+1
7249                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7250                   enddo
7251                 enddo
7252               enddo
7253             enddo
7254           endif
7255         enddo
7256         enddo
7257       enddo
7258       if (lprn) then
7259       write (iout,*)
7260      &  "Numbers of contacts to be sent to other processors",
7261      &  (ncont_sent(i),i=1,ntask_cont_to)
7262       write (iout,*) "Contacts sent"
7263       do ii=1,ntask_cont_to
7264         nn=ncont_sent(ii)
7265         iproc=itask_cont_to(ii)
7266         write (iout,*) nn," contacts to processor",iproc,
7267      &   " of CONT_TO_COMM group"
7268         do i=1,nn
7269           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7270         enddo
7271       enddo
7272       call flush(iout)
7273       endif
7274       CorrelType=477
7275       CorrelID=fg_rank+1
7276       CorrelType1=478
7277       CorrelID1=nfgtasks+fg_rank+1
7278       ireq=0
7279 C Receive the numbers of needed contacts from other processors
7280       do ii=1,ntask_cont_from
7281         iproc=itask_cont_from(ii)
7282         ireq=ireq+1
7283         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7284      &    FG_COMM,req(ireq),IERR)
7285       enddo
7286 c      write (iout,*) "IRECV ended"
7287 c      call flush(iout)
7288 C Send the number of contacts needed by other processors
7289       do ii=1,ntask_cont_to
7290         iproc=itask_cont_to(ii)
7291         ireq=ireq+1
7292         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7293      &    FG_COMM,req(ireq),IERR)
7294       enddo
7295 c      write (iout,*) "ISEND ended"
7296 c      write (iout,*) "number of requests (nn)",ireq
7297       call flush(iout)
7298       if (ireq.gt.0)
7299      &  call MPI_Waitall(ireq,req,status_array,ierr)
7300 c      write (iout,*)
7301 c     &  "Numbers of contacts to be received from other processors",
7302 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7303 c      call flush(iout)
7304 C Receive contacts
7305       ireq=0
7306       do ii=1,ntask_cont_from
7307         iproc=itask_cont_from(ii)
7308         nn=ncont_recv(ii)
7309 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7310 c     &   " of CONT_TO_COMM group"
7311         call flush(iout)
7312         if (nn.gt.0) then
7313           ireq=ireq+1
7314           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7315      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7316 c          write (iout,*) "ireq,req",ireq,req(ireq)
7317         endif
7318       enddo
7319 C Send the contacts to processors that need them
7320       do ii=1,ntask_cont_to
7321         iproc=itask_cont_to(ii)
7322         nn=ncont_sent(ii)
7323 c        write (iout,*) nn," contacts to processor",iproc,
7324 c     &   " of CONT_TO_COMM group"
7325         if (nn.gt.0) then
7326           ireq=ireq+1
7327           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7328      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7329 c          write (iout,*) "ireq,req",ireq,req(ireq)
7330 c          do i=1,nn
7331 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7332 c          enddo
7333         endif
7334       enddo
7335 c      write (iout,*) "number of requests (contacts)",ireq
7336 c      write (iout,*) "req",(req(i),i=1,4)
7337 c      call flush(iout)
7338       if (ireq.gt.0)
7339      & call MPI_Waitall(ireq,req,status_array,ierr)
7340       do iii=1,ntask_cont_from
7341         iproc=itask_cont_from(iii)
7342         nn=ncont_recv(iii)
7343         if (lprn) then
7344         write (iout,*) "Received",nn," contacts from processor",iproc,
7345      &   " of CONT_FROM_COMM group"
7346         call flush(iout)
7347         do i=1,nn
7348           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7349         enddo
7350         call flush(iout)
7351         endif
7352         do i=1,nn
7353           ii=zapas_recv(1,i,iii)
7354 c Flag the received contacts to prevent double-counting
7355           jj=-zapas_recv(2,i,iii)
7356 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7357 c          call flush(iout)
7358           nnn=num_cont_hb(ii)+1
7359           num_cont_hb(ii)=nnn
7360           jcont_hb(nnn,ii)=jj
7361           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7362           ind=3
7363           do kk=1,3
7364             ind=ind+1
7365             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7366           enddo
7367           do kk=1,2
7368             do ll=1,2
7369               ind=ind+1
7370               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7371             enddo
7372           enddo
7373           do jj=1,5
7374             do kk=1,3
7375               do ll=1,2
7376                 do mm=1,2
7377                   ind=ind+1
7378                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7379                 enddo
7380               enddo
7381             enddo
7382           enddo
7383         enddo
7384       enddo
7385       call flush(iout)
7386       if (lprn) then
7387         write (iout,'(a)') 'Contact function values after receive:'
7388         do i=nnt,nct-2
7389           write (iout,'(2i3,50(1x,i3,5f6.3))')
7390      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7391      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7392         enddo
7393         call flush(iout)
7394       endif
7395    30 continue
7396 #endif
7397       if (lprn) then
7398         write (iout,'(a)') 'Contact function values:'
7399         do i=nnt,nct-2
7400           write (iout,'(2i3,50(1x,i2,5f6.3))')
7401      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7402      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7403         enddo
7404       endif
7405       ecorr=0.0D0
7406       ecorr5=0.0d0
7407       ecorr6=0.0d0
7408 C Remove the loop below after debugging !!!
7409       do i=nnt,nct
7410         do j=1,3
7411           gradcorr(j,i)=0.0D0
7412           gradxorr(j,i)=0.0D0
7413         enddo
7414       enddo
7415 C Calculate the dipole-dipole interaction energies
7416       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7417       do i=iatel_s,iatel_e+1
7418         num_conti=num_cont_hb(i)
7419         do jj=1,num_conti
7420           j=jcont_hb(jj,i)
7421 #ifdef MOMENT
7422           call dipole(i,j,jj)
7423 #endif
7424         enddo
7425       enddo
7426       endif
7427 C Calculate the local-electrostatic correlation terms
7428 c                write (iout,*) "gradcorr5 in eello5 before loop"
7429 c                do iii=1,nres
7430 c                  write (iout,'(i5,3f10.5)')
7431 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7432 c                enddo
7433       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7434 c        write (iout,*) "corr loop i",i
7435         i1=i+1
7436         num_conti=num_cont_hb(i)
7437         num_conti1=num_cont_hb(i+1)
7438         do jj=1,num_conti
7439           j=jcont_hb(jj,i)
7440           jp=iabs(j)
7441           do kk=1,num_conti1
7442             j1=jcont_hb(kk,i1)
7443             jp1=iabs(j1)
7444 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7445 c     &         ' jj=',jj,' kk=',kk
7446 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7447             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7448      &          .or. j.lt.0 .and. j1.gt.0) .and.
7449      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7450 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7451 C The system gains extra energy.
7452               n_corr=n_corr+1
7453               sqd1=dsqrt(d_cont(jj,i))
7454               sqd2=dsqrt(d_cont(kk,i1))
7455               sred_geom = sqd1*sqd2
7456               IF (sred_geom.lt.cutoff_corr) THEN
7457                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7458      &            ekont,fprimcont)
7459 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7460 cd     &         ' jj=',jj,' kk=',kk
7461                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7462                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7463                 do l=1,3
7464                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7465                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7466                 enddo
7467                 n_corr1=n_corr1+1
7468 cd               write (iout,*) 'sred_geom=',sred_geom,
7469 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7470 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7471 cd               write (iout,*) "g_contij",g_contij
7472 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7473 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7474                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7475                 if (wcorr4.gt.0.0d0)
7476      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7477                   if (energy_dec.and.wcorr4.gt.0.0d0)
7478      1                 write (iout,'(a6,4i5,0pf7.3)')
7479      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7480 c                write (iout,*) "gradcorr5 before eello5"
7481 c                do iii=1,nres
7482 c                  write (iout,'(i5,3f10.5)')
7483 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7484 c                enddo
7485                 if (wcorr5.gt.0.0d0)
7486      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7487 c                write (iout,*) "gradcorr5 after eello5"
7488 c                do iii=1,nres
7489 c                  write (iout,'(i5,3f10.5)')
7490 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7491 c                enddo
7492                   if (energy_dec.and.wcorr5.gt.0.0d0)
7493      1                 write (iout,'(a6,4i5,0pf7.3)')
7494      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7495 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7496 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7497                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7498      &               .or. wturn6.eq.0.0d0))then
7499 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7500                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7501                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7502      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7503 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7504 cd     &            'ecorr6=',ecorr6
7505 cd                write (iout,'(4e15.5)') sred_geom,
7506 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7507 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7508 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7509                 else if (wturn6.gt.0.0d0
7510      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7511 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7512                   eturn6=eturn6+eello_turn6(i,jj,kk)
7513                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7514      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7515 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7516                 endif
7517               ENDIF
7518 1111          continue
7519             endif
7520           enddo ! kk
7521         enddo ! jj
7522       enddo ! i
7523       do i=1,nres
7524         num_cont_hb(i)=num_cont_hb_old(i)
7525       enddo
7526 c                write (iout,*) "gradcorr5 in eello5"
7527 c                do iii=1,nres
7528 c                  write (iout,'(i5,3f10.5)')
7529 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7530 c                enddo
7531       return
7532       end
7533 c------------------------------------------------------------------------------
7534       subroutine add_hb_contact_eello(ii,jj,itask)
7535       implicit real*8 (a-h,o-z)
7536       include "DIMENSIONS"
7537       include "COMMON.IOUNITS"
7538       integer max_cont
7539       integer max_dim
7540       parameter (max_cont=maxconts)
7541       parameter (max_dim=70)
7542       include "COMMON.CONTACTS"
7543       double precision zapas(max_dim,maxconts,max_fg_procs),
7544      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7545       common /przechowalnia/ zapas
7546       integer i,j,ii,jj,iproc,itask(4),nn
7547 c      write (iout,*) "itask",itask
7548       do i=1,2
7549         iproc=itask(i)
7550         if (iproc.gt.0) then
7551           do j=1,num_cont_hb(ii)
7552             jjc=jcont_hb(j,ii)
7553 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7554             if (jjc.eq.jj) then
7555               ncont_sent(iproc)=ncont_sent(iproc)+1
7556               nn=ncont_sent(iproc)
7557               zapas(1,nn,iproc)=ii
7558               zapas(2,nn,iproc)=jjc
7559               zapas(3,nn,iproc)=d_cont(j,ii)
7560               ind=3
7561               do kk=1,3
7562                 ind=ind+1
7563                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7564               enddo
7565               do kk=1,2
7566                 do ll=1,2
7567                   ind=ind+1
7568                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7569                 enddo
7570               enddo
7571               do jj=1,5
7572                 do kk=1,3
7573                   do ll=1,2
7574                     do mm=1,2
7575                       ind=ind+1
7576                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7577                     enddo
7578                   enddo
7579                 enddo
7580               enddo
7581               exit
7582             endif
7583           enddo
7584         endif
7585       enddo
7586       return
7587       end
7588 c------------------------------------------------------------------------------
7589       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7590       implicit real*8 (a-h,o-z)
7591       include 'DIMENSIONS'
7592       include 'COMMON.IOUNITS'
7593       include 'COMMON.DERIV'
7594       include 'COMMON.INTERACT'
7595       include 'COMMON.CONTACTS'
7596       double precision gx(3),gx1(3)
7597       logical lprn
7598       lprn=.false.
7599       eij=facont_hb(jj,i)
7600       ekl=facont_hb(kk,k)
7601       ees0pij=ees0p(jj,i)
7602       ees0pkl=ees0p(kk,k)
7603       ees0mij=ees0m(jj,i)
7604       ees0mkl=ees0m(kk,k)
7605       ekont=eij*ekl
7606       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7607 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7608 C Following 4 lines for diagnostics.
7609 cd    ees0pkl=0.0D0
7610 cd    ees0pij=1.0D0
7611 cd    ees0mkl=0.0D0
7612 cd    ees0mij=1.0D0
7613 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7614 c     & 'Contacts ',i,j,
7615 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7616 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7617 c     & 'gradcorr_long'
7618 C Calculate the multi-body contribution to energy.
7619 c      ecorr=ecorr+ekont*ees
7620 C Calculate multi-body contributions to the gradient.
7621       coeffpees0pij=coeffp*ees0pij
7622       coeffmees0mij=coeffm*ees0mij
7623       coeffpees0pkl=coeffp*ees0pkl
7624       coeffmees0mkl=coeffm*ees0mkl
7625       do ll=1,3
7626 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7627         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7628      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7629      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7630         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7631      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7632      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7633 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7634         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7635      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7636      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7637         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7638      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7639      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7640         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7641      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7642      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7643         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7644         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7645         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7646      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7647      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7648         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7649         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7650 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7651       enddo
7652 c      write (iout,*)
7653 cgrad      do m=i+1,j-1
7654 cgrad        do ll=1,3
7655 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7656 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7657 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7658 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7659 cgrad        enddo
7660 cgrad      enddo
7661 cgrad      do m=k+1,l-1
7662 cgrad        do ll=1,3
7663 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7664 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7665 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7666 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7667 cgrad        enddo
7668 cgrad      enddo
7669 c      write (iout,*) "ehbcorr",ekont*ees
7670       ehbcorr=ekont*ees
7671       return
7672       end
7673 #ifdef MOMENT
7674 C---------------------------------------------------------------------------
7675       subroutine dipole(i,j,jj)
7676       implicit real*8 (a-h,o-z)
7677       include 'DIMENSIONS'
7678       include 'COMMON.IOUNITS'
7679       include 'COMMON.CHAIN'
7680       include 'COMMON.FFIELD'
7681       include 'COMMON.DERIV'
7682       include 'COMMON.INTERACT'
7683       include 'COMMON.CONTACTS'
7684       include 'COMMON.TORSION'
7685       include 'COMMON.VAR'
7686       include 'COMMON.GEO'
7687       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7688      &  auxmat(2,2)
7689       iti1 = itortyp(itype(i+1))
7690       if (j.lt.nres-1) then
7691         itj1 = itortyp(itype(j+1))
7692       else
7693         itj1=ntortyp
7694       endif
7695       do iii=1,2
7696         dipi(iii,1)=Ub2(iii,i)
7697         dipderi(iii)=Ub2der(iii,i)
7698         dipi(iii,2)=b1(iii,i+1)
7699         dipj(iii,1)=Ub2(iii,j)
7700         dipderj(iii)=Ub2der(iii,j)
7701         dipj(iii,2)=b1(iii,j+1)
7702       enddo
7703       kkk=0
7704       do iii=1,2
7705         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7706         do jjj=1,2
7707           kkk=kkk+1
7708           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7709         enddo
7710       enddo
7711       do kkk=1,5
7712         do lll=1,3
7713           mmm=0
7714           do iii=1,2
7715             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7716      &        auxvec(1))
7717             do jjj=1,2
7718               mmm=mmm+1
7719               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7720             enddo
7721           enddo
7722         enddo
7723       enddo
7724       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7725       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7726       do iii=1,2
7727         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7728       enddo
7729       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7730       do iii=1,2
7731         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7732       enddo
7733       return
7734       end
7735 #endif
7736 C---------------------------------------------------------------------------
7737       subroutine calc_eello(i,j,k,l,jj,kk)
7738 C
7739 C This subroutine computes matrices and vectors needed to calculate
7740 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7741 C
7742       implicit real*8 (a-h,o-z)
7743       include 'DIMENSIONS'
7744       include 'COMMON.IOUNITS'
7745       include 'COMMON.CHAIN'
7746       include 'COMMON.DERIV'
7747       include 'COMMON.INTERACT'
7748       include 'COMMON.CONTACTS'
7749       include 'COMMON.TORSION'
7750       include 'COMMON.VAR'
7751       include 'COMMON.GEO'
7752       include 'COMMON.FFIELD'
7753       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7754      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7755       logical lprn
7756       common /kutas/ lprn
7757 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7758 cd     & ' jj=',jj,' kk=',kk
7759 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7760 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7761 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7762       do iii=1,2
7763         do jjj=1,2
7764           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7765           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7766         enddo
7767       enddo
7768       call transpose2(aa1(1,1),aa1t(1,1))
7769       call transpose2(aa2(1,1),aa2t(1,1))
7770       do kkk=1,5
7771         do lll=1,3
7772           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7773      &      aa1tder(1,1,lll,kkk))
7774           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7775      &      aa2tder(1,1,lll,kkk))
7776         enddo
7777       enddo
7778       if (l.eq.j+1) then
7779 C parallel orientation of the two CA-CA-CA frames.
7780         if (i.gt.1) then
7781           iti=itortyp(itype(i))
7782         else
7783           iti=ntortyp
7784         endif
7785         itk1=itortyp(itype(k+1))
7786         itj=itortyp(itype(j))
7787         if (l.lt.nres-1) then
7788           itl1=itortyp(itype(l+1))
7789         else
7790           itl1=ntortyp
7791         endif
7792 C A1 kernel(j+1) A2T
7793 cd        do iii=1,2
7794 cd          write (iout,'(3f10.5,5x,3f10.5)')
7795 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7796 cd        enddo
7797         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7798      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7799      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7800 C Following matrices are needed only for 6-th order cumulants
7801         IF (wcorr6.gt.0.0d0) THEN
7802         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7803      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7804      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7805         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7806      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7807      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7808      &   ADtEAderx(1,1,1,1,1,1))
7809         lprn=.false.
7810         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7811      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7812      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7813      &   ADtEA1derx(1,1,1,1,1,1))
7814         ENDIF
7815 C End 6-th order cumulants
7816 cd        lprn=.false.
7817 cd        if (lprn) then
7818 cd        write (2,*) 'In calc_eello6'
7819 cd        do iii=1,2
7820 cd          write (2,*) 'iii=',iii
7821 cd          do kkk=1,5
7822 cd            write (2,*) 'kkk=',kkk
7823 cd            do jjj=1,2
7824 cd              write (2,'(3(2f10.5),5x)')
7825 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7826 cd            enddo
7827 cd          enddo
7828 cd        enddo
7829 cd        endif
7830         call transpose2(EUgder(1,1,k),auxmat(1,1))
7831         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7832         call transpose2(EUg(1,1,k),auxmat(1,1))
7833         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7834         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7835         do iii=1,2
7836           do kkk=1,5
7837             do lll=1,3
7838               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7839      &          EAEAderx(1,1,lll,kkk,iii,1))
7840             enddo
7841           enddo
7842         enddo
7843 C A1T kernel(i+1) A2
7844         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7845      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7846      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7847 C Following matrices are needed only for 6-th order cumulants
7848         IF (wcorr6.gt.0.0d0) THEN
7849         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7850      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7851      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7852         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7853      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7854      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7855      &   ADtEAderx(1,1,1,1,1,2))
7856         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7857      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7858      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7859      &   ADtEA1derx(1,1,1,1,1,2))
7860         ENDIF
7861 C End 6-th order cumulants
7862         call transpose2(EUgder(1,1,l),auxmat(1,1))
7863         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7864         call transpose2(EUg(1,1,l),auxmat(1,1))
7865         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7866         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7867         do iii=1,2
7868           do kkk=1,5
7869             do lll=1,3
7870               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7871      &          EAEAderx(1,1,lll,kkk,iii,2))
7872             enddo
7873           enddo
7874         enddo
7875 C AEAb1 and AEAb2
7876 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7877 C They are needed only when the fifth- or the sixth-order cumulants are
7878 C indluded.
7879         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7880         call transpose2(AEA(1,1,1),auxmat(1,1))
7881         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7882         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7883         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7884         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7885         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7886         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7887         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7888         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7889         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7890         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7891         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7892         call transpose2(AEA(1,1,2),auxmat(1,1))
7893         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7894         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7895         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7896         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7897         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7898         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7899         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7900         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7901         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7902         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7903         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7904 C Calculate the Cartesian derivatives of the vectors.
7905         do iii=1,2
7906           do kkk=1,5
7907             do lll=1,3
7908               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7909               call matvec2(auxmat(1,1),b1(1,i),
7910      &          AEAb1derx(1,lll,kkk,iii,1,1))
7911               call matvec2(auxmat(1,1),Ub2(1,i),
7912      &          AEAb2derx(1,lll,kkk,iii,1,1))
7913               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7914      &          AEAb1derx(1,lll,kkk,iii,2,1))
7915               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7916      &          AEAb2derx(1,lll,kkk,iii,2,1))
7917               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7918               call matvec2(auxmat(1,1),b1(1,j),
7919      &          AEAb1derx(1,lll,kkk,iii,1,2))
7920               call matvec2(auxmat(1,1),Ub2(1,j),
7921      &          AEAb2derx(1,lll,kkk,iii,1,2))
7922               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7923      &          AEAb1derx(1,lll,kkk,iii,2,2))
7924               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7925      &          AEAb2derx(1,lll,kkk,iii,2,2))
7926             enddo
7927           enddo
7928         enddo
7929         ENDIF
7930 C End vectors
7931       else
7932 C Antiparallel orientation of the two CA-CA-CA frames.
7933         if (i.gt.1) then
7934           iti=itortyp(itype(i))
7935         else
7936           iti=ntortyp
7937         endif
7938         itk1=itortyp(itype(k+1))
7939         itl=itortyp(itype(l))
7940         itj=itortyp(itype(j))
7941         if (j.lt.nres-1) then
7942           itj1=itortyp(itype(j+1))
7943         else
7944           itj1=ntortyp
7945         endif
7946 C A2 kernel(j-1)T A1T
7947         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7948      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7949      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7950 C Following matrices are needed only for 6-th order cumulants
7951         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7952      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7953         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7954      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7955      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7956         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7957      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7958      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7959      &   ADtEAderx(1,1,1,1,1,1))
7960         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7961      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7962      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7963      &   ADtEA1derx(1,1,1,1,1,1))
7964         ENDIF
7965 C End 6-th order cumulants
7966         call transpose2(EUgder(1,1,k),auxmat(1,1))
7967         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7968         call transpose2(EUg(1,1,k),auxmat(1,1))
7969         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7970         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7971         do iii=1,2
7972           do kkk=1,5
7973             do lll=1,3
7974               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7975      &          EAEAderx(1,1,lll,kkk,iii,1))
7976             enddo
7977           enddo
7978         enddo
7979 C A2T kernel(i+1)T A1
7980         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7981      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7982      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7983 C Following matrices are needed only for 6-th order cumulants
7984         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7985      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7986         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7987      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7988      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7989         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7990      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7991      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7992      &   ADtEAderx(1,1,1,1,1,2))
7993         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7994      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7995      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7996      &   ADtEA1derx(1,1,1,1,1,2))
7997         ENDIF
7998 C End 6-th order cumulants
7999         call transpose2(EUgder(1,1,j),auxmat(1,1))
8000         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8001         call transpose2(EUg(1,1,j),auxmat(1,1))
8002         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8003         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8004         do iii=1,2
8005           do kkk=1,5
8006             do lll=1,3
8007               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8008      &          EAEAderx(1,1,lll,kkk,iii,2))
8009             enddo
8010           enddo
8011         enddo
8012 C AEAb1 and AEAb2
8013 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8014 C They are needed only when the fifth- or the sixth-order cumulants are
8015 C indluded.
8016         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8017      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8018         call transpose2(AEA(1,1,1),auxmat(1,1))
8019         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8020         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8021         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8022         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8023         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8024         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8025         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8026         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8027         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8028         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8029         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8030         call transpose2(AEA(1,1,2),auxmat(1,1))
8031         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8032         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8033         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8034         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8035         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8036         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8037         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8038         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8039         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8040         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8041         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8042 C Calculate the Cartesian derivatives of the vectors.
8043         do iii=1,2
8044           do kkk=1,5
8045             do lll=1,3
8046               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8047               call matvec2(auxmat(1,1),b1(1,i),
8048      &          AEAb1derx(1,lll,kkk,iii,1,1))
8049               call matvec2(auxmat(1,1),Ub2(1,i),
8050      &          AEAb2derx(1,lll,kkk,iii,1,1))
8051               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8052      &          AEAb1derx(1,lll,kkk,iii,2,1))
8053               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8054      &          AEAb2derx(1,lll,kkk,iii,2,1))
8055               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8056               call matvec2(auxmat(1,1),b1(1,l),
8057      &          AEAb1derx(1,lll,kkk,iii,1,2))
8058               call matvec2(auxmat(1,1),Ub2(1,l),
8059      &          AEAb2derx(1,lll,kkk,iii,1,2))
8060               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8061      &          AEAb1derx(1,lll,kkk,iii,2,2))
8062               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8063      &          AEAb2derx(1,lll,kkk,iii,2,2))
8064             enddo
8065           enddo
8066         enddo
8067         ENDIF
8068 C End vectors
8069       endif
8070       return
8071       end
8072 C---------------------------------------------------------------------------
8073       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8074      &  KK,KKderg,AKA,AKAderg,AKAderx)
8075       implicit none
8076       integer nderg
8077       logical transp
8078       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8079      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8080      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8081       integer iii,kkk,lll
8082       integer jjj,mmm
8083       logical lprn
8084       common /kutas/ lprn
8085       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8086       do iii=1,nderg
8087         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8088      &    AKAderg(1,1,iii))
8089       enddo
8090 cd      if (lprn) write (2,*) 'In kernel'
8091       do kkk=1,5
8092 cd        if (lprn) write (2,*) 'kkk=',kkk
8093         do lll=1,3
8094           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8095      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8096 cd          if (lprn) then
8097 cd            write (2,*) 'lll=',lll
8098 cd            write (2,*) 'iii=1'
8099 cd            do jjj=1,2
8100 cd              write (2,'(3(2f10.5),5x)')
8101 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8102 cd            enddo
8103 cd          endif
8104           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8105      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8106 cd          if (lprn) then
8107 cd            write (2,*) 'lll=',lll
8108 cd            write (2,*) 'iii=2'
8109 cd            do jjj=1,2
8110 cd              write (2,'(3(2f10.5),5x)')
8111 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8112 cd            enddo
8113 cd          endif
8114         enddo
8115       enddo
8116       return
8117       end
8118 C---------------------------------------------------------------------------
8119       double precision function eello4(i,j,k,l,jj,kk)
8120       implicit real*8 (a-h,o-z)
8121       include 'DIMENSIONS'
8122       include 'COMMON.IOUNITS'
8123       include 'COMMON.CHAIN'
8124       include 'COMMON.DERIV'
8125       include 'COMMON.INTERACT'
8126       include 'COMMON.CONTACTS'
8127       include 'COMMON.TORSION'
8128       include 'COMMON.VAR'
8129       include 'COMMON.GEO'
8130       double precision pizda(2,2),ggg1(3),ggg2(3)
8131 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8132 cd        eello4=0.0d0
8133 cd        return
8134 cd      endif
8135 cd      print *,'eello4:',i,j,k,l,jj,kk
8136 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8137 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8138 cold      eij=facont_hb(jj,i)
8139 cold      ekl=facont_hb(kk,k)
8140 cold      ekont=eij*ekl
8141       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8142 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8143       gcorr_loc(k-1)=gcorr_loc(k-1)
8144      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8145       if (l.eq.j+1) then
8146         gcorr_loc(l-1)=gcorr_loc(l-1)
8147      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8148       else
8149         gcorr_loc(j-1)=gcorr_loc(j-1)
8150      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8151       endif
8152       do iii=1,2
8153         do kkk=1,5
8154           do lll=1,3
8155             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8156      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8157 cd            derx(lll,kkk,iii)=0.0d0
8158           enddo
8159         enddo
8160       enddo
8161 cd      gcorr_loc(l-1)=0.0d0
8162 cd      gcorr_loc(j-1)=0.0d0
8163 cd      gcorr_loc(k-1)=0.0d0
8164 cd      eel4=1.0d0
8165 cd      write (iout,*)'Contacts have occurred for peptide groups',
8166 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8167 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8168       if (j.lt.nres-1) then
8169         j1=j+1
8170         j2=j-1
8171       else
8172         j1=j-1
8173         j2=j-2
8174       endif
8175       if (l.lt.nres-1) then
8176         l1=l+1
8177         l2=l-1
8178       else
8179         l1=l-1
8180         l2=l-2
8181       endif
8182       do ll=1,3
8183 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8184 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8185         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8186         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8187 cgrad        ghalf=0.5d0*ggg1(ll)
8188         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8189         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8190         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8191         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8192         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8193         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8194 cgrad        ghalf=0.5d0*ggg2(ll)
8195         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8196         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8197         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8198         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8199         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8200         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8201       enddo
8202 cgrad      do m=i+1,j-1
8203 cgrad        do ll=1,3
8204 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8205 cgrad        enddo
8206 cgrad      enddo
8207 cgrad      do m=k+1,l-1
8208 cgrad        do ll=1,3
8209 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8210 cgrad        enddo
8211 cgrad      enddo
8212 cgrad      do m=i+2,j2
8213 cgrad        do ll=1,3
8214 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8215 cgrad        enddo
8216 cgrad      enddo
8217 cgrad      do m=k+2,l2
8218 cgrad        do ll=1,3
8219 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8220 cgrad        enddo
8221 cgrad      enddo
8222 cd      do iii=1,nres-3
8223 cd        write (2,*) iii,gcorr_loc(iii)
8224 cd      enddo
8225       eello4=ekont*eel4
8226 cd      write (2,*) 'ekont',ekont
8227 cd      write (iout,*) 'eello4',ekont*eel4
8228       return
8229       end
8230 C---------------------------------------------------------------------------
8231       double precision function eello5(i,j,k,l,jj,kk)
8232       implicit real*8 (a-h,o-z)
8233       include 'DIMENSIONS'
8234       include 'COMMON.IOUNITS'
8235       include 'COMMON.CHAIN'
8236       include 'COMMON.DERIV'
8237       include 'COMMON.INTERACT'
8238       include 'COMMON.CONTACTS'
8239       include 'COMMON.TORSION'
8240       include 'COMMON.VAR'
8241       include 'COMMON.GEO'
8242       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8243       double precision ggg1(3),ggg2(3)
8244 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8245 C                                                                              C
8246 C                            Parallel chains                                   C
8247 C                                                                              C
8248 C          o             o                   o             o                   C
8249 C         /l\           / \             \   / \           / \   /              C
8250 C        /   \         /   \             \ /   \         /   \ /               C
8251 C       j| o |l1       | o |              o| o |         | o |o                C
8252 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8253 C      \i/   \         /   \ /             /   \         /   \                 C
8254 C       o    k1             o                                                  C
8255 C         (I)          (II)                (III)          (IV)                 C
8256 C                                                                              C
8257 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8258 C                                                                              C
8259 C                            Antiparallel chains                               C
8260 C                                                                              C
8261 C          o             o                   o             o                   C
8262 C         /j\           / \             \   / \           / \   /              C
8263 C        /   \         /   \             \ /   \         /   \ /               C
8264 C      j1| o |l        | o |              o| o |         | o |o                C
8265 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8266 C      \i/   \         /   \ /             /   \         /   \                 C
8267 C       o     k1            o                                                  C
8268 C         (I)          (II)                (III)          (IV)                 C
8269 C                                                                              C
8270 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8271 C                                                                              C
8272 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8273 C                                                                              C
8274 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8275 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8276 cd        eello5=0.0d0
8277 cd        return
8278 cd      endif
8279 cd      write (iout,*)
8280 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8281 cd     &   ' and',k,l
8282       itk=itortyp(itype(k))
8283       itl=itortyp(itype(l))
8284       itj=itortyp(itype(j))
8285       eello5_1=0.0d0
8286       eello5_2=0.0d0
8287       eello5_3=0.0d0
8288       eello5_4=0.0d0
8289 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8290 cd     &   eel5_3_num,eel5_4_num)
8291       do iii=1,2
8292         do kkk=1,5
8293           do lll=1,3
8294             derx(lll,kkk,iii)=0.0d0
8295           enddo
8296         enddo
8297       enddo
8298 cd      eij=facont_hb(jj,i)
8299 cd      ekl=facont_hb(kk,k)
8300 cd      ekont=eij*ekl
8301 cd      write (iout,*)'Contacts have occurred for peptide groups',
8302 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8303 cd      goto 1111
8304 C Contribution from the graph I.
8305 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8306 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8307       call transpose2(EUg(1,1,k),auxmat(1,1))
8308       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8309       vv(1)=pizda(1,1)-pizda(2,2)
8310       vv(2)=pizda(1,2)+pizda(2,1)
8311       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8312      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8313 C Explicit gradient in virtual-dihedral angles.
8314       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8315      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8316      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8317       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8318       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8319       vv(1)=pizda(1,1)-pizda(2,2)
8320       vv(2)=pizda(1,2)+pizda(2,1)
8321       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8322      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8323      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8324       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8325       vv(1)=pizda(1,1)-pizda(2,2)
8326       vv(2)=pizda(1,2)+pizda(2,1)
8327       if (l.eq.j+1) then
8328         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8329      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8330      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8331       else
8332         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8333      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8334      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8335       endif
8336 C Cartesian gradient
8337       do iii=1,2
8338         do kkk=1,5
8339           do lll=1,3
8340             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8341      &        pizda(1,1))
8342             vv(1)=pizda(1,1)-pizda(2,2)
8343             vv(2)=pizda(1,2)+pizda(2,1)
8344             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8345      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8346      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8347           enddo
8348         enddo
8349       enddo
8350 c      goto 1112
8351 c1111  continue
8352 C Contribution from graph II
8353       call transpose2(EE(1,1,itk),auxmat(1,1))
8354       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8355       vv(1)=pizda(1,1)+pizda(2,2)
8356       vv(2)=pizda(2,1)-pizda(1,2)
8357       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8358      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8359 C Explicit gradient in virtual-dihedral angles.
8360       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8361      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8362       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8363       vv(1)=pizda(1,1)+pizda(2,2)
8364       vv(2)=pizda(2,1)-pizda(1,2)
8365       if (l.eq.j+1) then
8366         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8367      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8368      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8369       else
8370         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8371      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8372      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8373       endif
8374 C Cartesian gradient
8375       do iii=1,2
8376         do kkk=1,5
8377           do lll=1,3
8378             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8379      &        pizda(1,1))
8380             vv(1)=pizda(1,1)+pizda(2,2)
8381             vv(2)=pizda(2,1)-pizda(1,2)
8382             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8383      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8384      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8385           enddo
8386         enddo
8387       enddo
8388 cd      goto 1112
8389 cd1111  continue
8390       if (l.eq.j+1) then
8391 cd        goto 1110
8392 C Parallel orientation
8393 C Contribution from graph III
8394         call transpose2(EUg(1,1,l),auxmat(1,1))
8395         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8396         vv(1)=pizda(1,1)-pizda(2,2)
8397         vv(2)=pizda(1,2)+pizda(2,1)
8398         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8399      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8400 C Explicit gradient in virtual-dihedral angles.
8401         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8402      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8403      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8404         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8405         vv(1)=pizda(1,1)-pizda(2,2)
8406         vv(2)=pizda(1,2)+pizda(2,1)
8407         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8408      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8409      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8410         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8411         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8412         vv(1)=pizda(1,1)-pizda(2,2)
8413         vv(2)=pizda(1,2)+pizda(2,1)
8414         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8415      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8416      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8417 C Cartesian gradient
8418         do iii=1,2
8419           do kkk=1,5
8420             do lll=1,3
8421               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8422      &          pizda(1,1))
8423               vv(1)=pizda(1,1)-pizda(2,2)
8424               vv(2)=pizda(1,2)+pizda(2,1)
8425               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8426      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8427      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8428             enddo
8429           enddo
8430         enddo
8431 cd        goto 1112
8432 C Contribution from graph IV
8433 cd1110    continue
8434         call transpose2(EE(1,1,itl),auxmat(1,1))
8435         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8436         vv(1)=pizda(1,1)+pizda(2,2)
8437         vv(2)=pizda(2,1)-pizda(1,2)
8438         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8439      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8440 C Explicit gradient in virtual-dihedral angles.
8441         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8442      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8443         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8444         vv(1)=pizda(1,1)+pizda(2,2)
8445         vv(2)=pizda(2,1)-pizda(1,2)
8446         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8447      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8448      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8449 C Cartesian gradient
8450         do iii=1,2
8451           do kkk=1,5
8452             do lll=1,3
8453               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8454      &          pizda(1,1))
8455               vv(1)=pizda(1,1)+pizda(2,2)
8456               vv(2)=pizda(2,1)-pizda(1,2)
8457               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8458      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8459      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8460             enddo
8461           enddo
8462         enddo
8463       else
8464 C Antiparallel orientation
8465 C Contribution from graph III
8466 c        goto 1110
8467         call transpose2(EUg(1,1,j),auxmat(1,1))
8468         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8469         vv(1)=pizda(1,1)-pizda(2,2)
8470         vv(2)=pizda(1,2)+pizda(2,1)
8471         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8472      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8473 C Explicit gradient in virtual-dihedral angles.
8474         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8475      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8476      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8477         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8478         vv(1)=pizda(1,1)-pizda(2,2)
8479         vv(2)=pizda(1,2)+pizda(2,1)
8480         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8481      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8483         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8484         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8485         vv(1)=pizda(1,1)-pizda(2,2)
8486         vv(2)=pizda(1,2)+pizda(2,1)
8487         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8488      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8489      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8490 C Cartesian gradient
8491         do iii=1,2
8492           do kkk=1,5
8493             do lll=1,3
8494               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8495      &          pizda(1,1))
8496               vv(1)=pizda(1,1)-pizda(2,2)
8497               vv(2)=pizda(1,2)+pizda(2,1)
8498               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8499      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8500      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8501             enddo
8502           enddo
8503         enddo
8504 cd        goto 1112
8505 C Contribution from graph IV
8506 1110    continue
8507         call transpose2(EE(1,1,itj),auxmat(1,1))
8508         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8509         vv(1)=pizda(1,1)+pizda(2,2)
8510         vv(2)=pizda(2,1)-pizda(1,2)
8511         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8512      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8513 C Explicit gradient in virtual-dihedral angles.
8514         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8515      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8516         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8517         vv(1)=pizda(1,1)+pizda(2,2)
8518         vv(2)=pizda(2,1)-pizda(1,2)
8519         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8520      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8521      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8522 C Cartesian gradient
8523         do iii=1,2
8524           do kkk=1,5
8525             do lll=1,3
8526               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8527      &          pizda(1,1))
8528               vv(1)=pizda(1,1)+pizda(2,2)
8529               vv(2)=pizda(2,1)-pizda(1,2)
8530               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8531      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8532      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8533             enddo
8534           enddo
8535         enddo
8536       endif
8537 1112  continue
8538       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8539 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8540 cd        write (2,*) 'ijkl',i,j,k,l
8541 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8542 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8543 cd      endif
8544 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8545 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8546 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8547 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8548       if (j.lt.nres-1) then
8549         j1=j+1
8550         j2=j-1
8551       else
8552         j1=j-1
8553         j2=j-2
8554       endif
8555       if (l.lt.nres-1) then
8556         l1=l+1
8557         l2=l-1
8558       else
8559         l1=l-1
8560         l2=l-2
8561       endif
8562 cd      eij=1.0d0
8563 cd      ekl=1.0d0
8564 cd      ekont=1.0d0
8565 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8566 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8567 C        summed up outside the subrouine as for the other subroutines
8568 C        handling long-range interactions. The old code is commented out
8569 C        with "cgrad" to keep track of changes.
8570       do ll=1,3
8571 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8572 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8573         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8574         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8575 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8576 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8577 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8578 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8579 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8580 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8581 c     &   gradcorr5ij,
8582 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8583 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8584 cgrad        ghalf=0.5d0*ggg1(ll)
8585 cd        ghalf=0.0d0
8586         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8587         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8588         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8589         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8590         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8591         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8592 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8593 cgrad        ghalf=0.5d0*ggg2(ll)
8594 cd        ghalf=0.0d0
8595         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8596         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8597         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8598         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8599         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8600         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8601       enddo
8602 cd      goto 1112
8603 cgrad      do m=i+1,j-1
8604 cgrad        do ll=1,3
8605 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8606 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8607 cgrad        enddo
8608 cgrad      enddo
8609 cgrad      do m=k+1,l-1
8610 cgrad        do ll=1,3
8611 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8612 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8613 cgrad        enddo
8614 cgrad      enddo
8615 c1112  continue
8616 cgrad      do m=i+2,j2
8617 cgrad        do ll=1,3
8618 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8619 cgrad        enddo
8620 cgrad      enddo
8621 cgrad      do m=k+2,l2
8622 cgrad        do ll=1,3
8623 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8624 cgrad        enddo
8625 cgrad      enddo
8626 cd      do iii=1,nres-3
8627 cd        write (2,*) iii,g_corr5_loc(iii)
8628 cd      enddo
8629       eello5=ekont*eel5
8630 cd      write (2,*) 'ekont',ekont
8631 cd      write (iout,*) 'eello5',ekont*eel5
8632       return
8633       end
8634 c--------------------------------------------------------------------------
8635       double precision function eello6(i,j,k,l,jj,kk)
8636       implicit real*8 (a-h,o-z)
8637       include 'DIMENSIONS'
8638       include 'COMMON.IOUNITS'
8639       include 'COMMON.CHAIN'
8640       include 'COMMON.DERIV'
8641       include 'COMMON.INTERACT'
8642       include 'COMMON.CONTACTS'
8643       include 'COMMON.TORSION'
8644       include 'COMMON.VAR'
8645       include 'COMMON.GEO'
8646       include 'COMMON.FFIELD'
8647       double precision ggg1(3),ggg2(3)
8648 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8649 cd        eello6=0.0d0
8650 cd        return
8651 cd      endif
8652 cd      write (iout,*)
8653 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8654 cd     &   ' and',k,l
8655       eello6_1=0.0d0
8656       eello6_2=0.0d0
8657       eello6_3=0.0d0
8658       eello6_4=0.0d0
8659       eello6_5=0.0d0
8660       eello6_6=0.0d0
8661 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8662 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8663       do iii=1,2
8664         do kkk=1,5
8665           do lll=1,3
8666             derx(lll,kkk,iii)=0.0d0
8667           enddo
8668         enddo
8669       enddo
8670 cd      eij=facont_hb(jj,i)
8671 cd      ekl=facont_hb(kk,k)
8672 cd      ekont=eij*ekl
8673 cd      eij=1.0d0
8674 cd      ekl=1.0d0
8675 cd      ekont=1.0d0
8676       if (l.eq.j+1) then
8677         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8678         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8679         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8680         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8681         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8682         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8683       else
8684         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8685         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8686         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8687         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8688         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8689           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8690         else
8691           eello6_5=0.0d0
8692         endif
8693         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8694       endif
8695 C If turn contributions are considered, they will be handled separately.
8696       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8697 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8698 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8699 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8700 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8701 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8702 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8703 cd      goto 1112
8704       if (j.lt.nres-1) then
8705         j1=j+1
8706         j2=j-1
8707       else
8708         j1=j-1
8709         j2=j-2
8710       endif
8711       if (l.lt.nres-1) then
8712         l1=l+1
8713         l2=l-1
8714       else
8715         l1=l-1
8716         l2=l-2
8717       endif
8718       do ll=1,3
8719 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8720 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8721 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8722 cgrad        ghalf=0.5d0*ggg1(ll)
8723 cd        ghalf=0.0d0
8724         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8725         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8726         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8727         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8728         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8729         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8730         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8731         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8732 cgrad        ghalf=0.5d0*ggg2(ll)
8733 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8734 cd        ghalf=0.0d0
8735         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8736         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8737         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8738         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8739         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8740         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8741       enddo
8742 cd      goto 1112
8743 cgrad      do m=i+1,j-1
8744 cgrad        do ll=1,3
8745 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8746 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8747 cgrad        enddo
8748 cgrad      enddo
8749 cgrad      do m=k+1,l-1
8750 cgrad        do ll=1,3
8751 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8752 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8753 cgrad        enddo
8754 cgrad      enddo
8755 cgrad1112  continue
8756 cgrad      do m=i+2,j2
8757 cgrad        do ll=1,3
8758 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8759 cgrad        enddo
8760 cgrad      enddo
8761 cgrad      do m=k+2,l2
8762 cgrad        do ll=1,3
8763 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8764 cgrad        enddo
8765 cgrad      enddo
8766 cd      do iii=1,nres-3
8767 cd        write (2,*) iii,g_corr6_loc(iii)
8768 cd      enddo
8769       eello6=ekont*eel6
8770 cd      write (2,*) 'ekont',ekont
8771 cd      write (iout,*) 'eello6',ekont*eel6
8772       return
8773       end
8774 c--------------------------------------------------------------------------
8775       double precision function eello6_graph1(i,j,k,l,imat,swap)
8776       implicit real*8 (a-h,o-z)
8777       include 'DIMENSIONS'
8778       include 'COMMON.IOUNITS'
8779       include 'COMMON.CHAIN'
8780       include 'COMMON.DERIV'
8781       include 'COMMON.INTERACT'
8782       include 'COMMON.CONTACTS'
8783       include 'COMMON.TORSION'
8784       include 'COMMON.VAR'
8785       include 'COMMON.GEO'
8786       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8787       logical swap
8788       logical lprn
8789       common /kutas/ lprn
8790 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8791 C                                                                              C
8792 C      Parallel       Antiparallel                                             C
8793 C                                                                              C
8794 C          o             o                                                     C
8795 C         /l\           /j\                                                    C
8796 C        /   \         /   \                                                   C
8797 C       /| o |         | o |\                                                  C
8798 C     \ j|/k\|  /   \  |/k\|l /                                                C
8799 C      \ /   \ /     \ /   \ /                                                 C
8800 C       o     o       o     o                                                  C
8801 C       i             i                                                        C
8802 C                                                                              C
8803 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8804       itk=itortyp(itype(k))
8805       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8806       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8807       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8808       call transpose2(EUgC(1,1,k),auxmat(1,1))
8809       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8810       vv1(1)=pizda1(1,1)-pizda1(2,2)
8811       vv1(2)=pizda1(1,2)+pizda1(2,1)
8812       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8813       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8814       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8815       s5=scalar2(vv(1),Dtobr2(1,i))
8816 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8817       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8818       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8819      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8820      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8821      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8822      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8823      & +scalar2(vv(1),Dtobr2der(1,i)))
8824       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8825       vv1(1)=pizda1(1,1)-pizda1(2,2)
8826       vv1(2)=pizda1(1,2)+pizda1(2,1)
8827       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8828       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8829       if (l.eq.j+1) then
8830         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8831      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8832      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8833      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8834      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8835       else
8836         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8837      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8838      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8839      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8840      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8841       endif
8842       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8843       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8844       vv1(1)=pizda1(1,1)-pizda1(2,2)
8845       vv1(2)=pizda1(1,2)+pizda1(2,1)
8846       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8847      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8848      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8849      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8850       do iii=1,2
8851         if (swap) then
8852           ind=3-iii
8853         else
8854           ind=iii
8855         endif
8856         do kkk=1,5
8857           do lll=1,3
8858             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8859             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8860             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8861             call transpose2(EUgC(1,1,k),auxmat(1,1))
8862             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8863      &        pizda1(1,1))
8864             vv1(1)=pizda1(1,1)-pizda1(2,2)
8865             vv1(2)=pizda1(1,2)+pizda1(2,1)
8866             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8867             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8868      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8869             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8870      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8871             s5=scalar2(vv(1),Dtobr2(1,i))
8872             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8873           enddo
8874         enddo
8875       enddo
8876       return
8877       end
8878 c----------------------------------------------------------------------------
8879       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8880       implicit real*8 (a-h,o-z)
8881       include 'DIMENSIONS'
8882       include 'COMMON.IOUNITS'
8883       include 'COMMON.CHAIN'
8884       include 'COMMON.DERIV'
8885       include 'COMMON.INTERACT'
8886       include 'COMMON.CONTACTS'
8887       include 'COMMON.TORSION'
8888       include 'COMMON.VAR'
8889       include 'COMMON.GEO'
8890       logical swap
8891       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8892      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8893       logical lprn
8894       common /kutas/ lprn
8895 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8896 C                                                                              C
8897 C      Parallel       Antiparallel                                             C
8898 C                                                                              C
8899 C          o             o                                                     C
8900 C     \   /l\           /j\   /                                                C
8901 C      \ /   \         /   \ /                                                 C
8902 C       o| o |         | o |o                                                  C
8903 C     \ j|/k\|      \  |/k\|l                                                  C
8904 C      \ /   \       \ /   \                                                   C
8905 C       o             o                                                        C
8906 C       i             i                                                        C
8907 C                                                                              C
8908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8909 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8910 C AL 7/4/01 s1 would occur in the sixth-order moment,
8911 C           but not in a cluster cumulant
8912 #ifdef MOMENT
8913       s1=dip(1,jj,i)*dip(1,kk,k)
8914 #endif
8915       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8916       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8917       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8918       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8919       call transpose2(EUg(1,1,k),auxmat(1,1))
8920       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8921       vv(1)=pizda(1,1)-pizda(2,2)
8922       vv(2)=pizda(1,2)+pizda(2,1)
8923       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8924 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8925 #ifdef MOMENT
8926       eello6_graph2=-(s1+s2+s3+s4)
8927 #else
8928       eello6_graph2=-(s2+s3+s4)
8929 #endif
8930 c      eello6_graph2=-s3
8931 C Derivatives in gamma(i-1)
8932       if (i.gt.1) then
8933 #ifdef MOMENT
8934         s1=dipderg(1,jj,i)*dip(1,kk,k)
8935 #endif
8936         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8937         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8938         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8939         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8940 #ifdef MOMENT
8941         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8942 #else
8943         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8944 #endif
8945 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8946       endif
8947 C Derivatives in gamma(k-1)
8948 #ifdef MOMENT
8949       s1=dip(1,jj,i)*dipderg(1,kk,k)
8950 #endif
8951       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8952       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8953       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8954       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8955       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8956       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8957       vv(1)=pizda(1,1)-pizda(2,2)
8958       vv(2)=pizda(1,2)+pizda(2,1)
8959       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8960 #ifdef MOMENT
8961       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8962 #else
8963       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8964 #endif
8965 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8966 C Derivatives in gamma(j-1) or gamma(l-1)
8967       if (j.gt.1) then
8968 #ifdef MOMENT
8969         s1=dipderg(3,jj,i)*dip(1,kk,k)
8970 #endif
8971         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8972         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8973         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8974         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8975         vv(1)=pizda(1,1)-pizda(2,2)
8976         vv(2)=pizda(1,2)+pizda(2,1)
8977         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8978 #ifdef MOMENT
8979         if (swap) then
8980           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8981         else
8982           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8983         endif
8984 #endif
8985         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8986 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8987       endif
8988 C Derivatives in gamma(l-1) or gamma(j-1)
8989       if (l.gt.1) then
8990 #ifdef MOMENT
8991         s1=dip(1,jj,i)*dipderg(3,kk,k)
8992 #endif
8993         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8994         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8995         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8996         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8997         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8998         vv(1)=pizda(1,1)-pizda(2,2)
8999         vv(2)=pizda(1,2)+pizda(2,1)
9000         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9001 #ifdef MOMENT
9002         if (swap) then
9003           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9004         else
9005           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9006         endif
9007 #endif
9008         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9009 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9010       endif
9011 C Cartesian derivatives.
9012       if (lprn) then
9013         write (2,*) 'In eello6_graph2'
9014         do iii=1,2
9015           write (2,*) 'iii=',iii
9016           do kkk=1,5
9017             write (2,*) 'kkk=',kkk
9018             do jjj=1,2
9019               write (2,'(3(2f10.5),5x)')
9020      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9021             enddo
9022           enddo
9023         enddo
9024       endif
9025       do iii=1,2
9026         do kkk=1,5
9027           do lll=1,3
9028 #ifdef MOMENT
9029             if (iii.eq.1) then
9030               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9031             else
9032               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9033             endif
9034 #endif
9035             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9036      &        auxvec(1))
9037             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9038             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9039      &        auxvec(1))
9040             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9041             call transpose2(EUg(1,1,k),auxmat(1,1))
9042             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9043      &        pizda(1,1))
9044             vv(1)=pizda(1,1)-pizda(2,2)
9045             vv(2)=pizda(1,2)+pizda(2,1)
9046             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9047 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9048 #ifdef MOMENT
9049             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9050 #else
9051             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9052 #endif
9053             if (swap) then
9054               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9055             else
9056               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9057             endif
9058           enddo
9059         enddo
9060       enddo
9061       return
9062       end
9063 c----------------------------------------------------------------------------
9064       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9065       implicit real*8 (a-h,o-z)
9066       include 'DIMENSIONS'
9067       include 'COMMON.IOUNITS'
9068       include 'COMMON.CHAIN'
9069       include 'COMMON.DERIV'
9070       include 'COMMON.INTERACT'
9071       include 'COMMON.CONTACTS'
9072       include 'COMMON.TORSION'
9073       include 'COMMON.VAR'
9074       include 'COMMON.GEO'
9075       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9076       logical swap
9077 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9078 C                                                                              C
9079 C      Parallel       Antiparallel                                             C
9080 C                                                                              C
9081 C          o             o                                                     C
9082 C         /l\   /   \   /j\                                                    C
9083 C        /   \ /     \ /   \                                                   C
9084 C       /| o |o       o| o |\                                                  C
9085 C       j|/k\|  /      |/k\|l /                                                C
9086 C        /   \ /       /   \ /                                                 C
9087 C       /     o       /     o                                                  C
9088 C       i             i                                                        C
9089 C                                                                              C
9090 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9091 C
9092 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9093 C           energy moment and not to the cluster cumulant.
9094       iti=itortyp(itype(i))
9095       if (j.lt.nres-1) then
9096         itj1=itortyp(itype(j+1))
9097       else
9098         itj1=ntortyp
9099       endif
9100       itk=itortyp(itype(k))
9101       itk1=itortyp(itype(k+1))
9102       if (l.lt.nres-1) then
9103         itl1=itortyp(itype(l+1))
9104       else
9105         itl1=ntortyp
9106       endif
9107 #ifdef MOMENT
9108       s1=dip(4,jj,i)*dip(4,kk,k)
9109 #endif
9110       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9111       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9112       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9113       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9114       call transpose2(EE(1,1,itk),auxmat(1,1))
9115       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9116       vv(1)=pizda(1,1)+pizda(2,2)
9117       vv(2)=pizda(2,1)-pizda(1,2)
9118       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9119 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9120 cd     & "sum",-(s2+s3+s4)
9121 #ifdef MOMENT
9122       eello6_graph3=-(s1+s2+s3+s4)
9123 #else
9124       eello6_graph3=-(s2+s3+s4)
9125 #endif
9126 c      eello6_graph3=-s4
9127 C Derivatives in gamma(k-1)
9128       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9129       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9130       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9131       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9132 C Derivatives in gamma(l-1)
9133       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9134       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9135       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9136       vv(1)=pizda(1,1)+pizda(2,2)
9137       vv(2)=pizda(2,1)-pizda(1,2)
9138       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9139       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9140 C Cartesian derivatives.
9141       do iii=1,2
9142         do kkk=1,5
9143           do lll=1,3
9144 #ifdef MOMENT
9145             if (iii.eq.1) then
9146               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9147             else
9148               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9149             endif
9150 #endif
9151             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9152      &        auxvec(1))
9153             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9154             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9155      &        auxvec(1))
9156             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9157             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9158      &        pizda(1,1))
9159             vv(1)=pizda(1,1)+pizda(2,2)
9160             vv(2)=pizda(2,1)-pizda(1,2)
9161             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9162 #ifdef MOMENT
9163             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9164 #else
9165             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9166 #endif
9167             if (swap) then
9168               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9169             else
9170               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9171             endif
9172 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9173           enddo
9174         enddo
9175       enddo
9176       return
9177       end
9178 c----------------------------------------------------------------------------
9179       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9180       implicit real*8 (a-h,o-z)
9181       include 'DIMENSIONS'
9182       include 'COMMON.IOUNITS'
9183       include 'COMMON.CHAIN'
9184       include 'COMMON.DERIV'
9185       include 'COMMON.INTERACT'
9186       include 'COMMON.CONTACTS'
9187       include 'COMMON.TORSION'
9188       include 'COMMON.VAR'
9189       include 'COMMON.GEO'
9190       include 'COMMON.FFIELD'
9191       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9192      & auxvec1(2),auxmat1(2,2)
9193       logical swap
9194 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9195 C                                                                              C
9196 C      Parallel       Antiparallel                                             C
9197 C                                                                              C
9198 C          o             o                                                     C
9199 C         /l\   /   \   /j\                                                    C
9200 C        /   \ /     \ /   \                                                   C
9201 C       /| o |o       o| o |\                                                  C
9202 C     \ j|/k\|      \  |/k\|l                                                  C
9203 C      \ /   \       \ /   \                                                   C
9204 C       o     \       o     \                                                  C
9205 C       i             i                                                        C
9206 C                                                                              C
9207 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9208 C
9209 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9210 C           energy moment and not to the cluster cumulant.
9211 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9212       iti=itortyp(itype(i))
9213       itj=itortyp(itype(j))
9214       if (j.lt.nres-1) then
9215         itj1=itortyp(itype(j+1))
9216       else
9217         itj1=ntortyp
9218       endif
9219       itk=itortyp(itype(k))
9220       if (k.lt.nres-1) then
9221         itk1=itortyp(itype(k+1))
9222       else
9223         itk1=ntortyp
9224       endif
9225       itl=itortyp(itype(l))
9226       if (l.lt.nres-1) then
9227         itl1=itortyp(itype(l+1))
9228       else
9229         itl1=ntortyp
9230       endif
9231 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9232 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9233 cd     & ' itl',itl,' itl1',itl1
9234 #ifdef MOMENT
9235       if (imat.eq.1) then
9236         s1=dip(3,jj,i)*dip(3,kk,k)
9237       else
9238         s1=dip(2,jj,j)*dip(2,kk,l)
9239       endif
9240 #endif
9241       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9242       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9243       if (j.eq.l+1) then
9244         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9245         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9246       else
9247         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9248         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9249       endif
9250       call transpose2(EUg(1,1,k),auxmat(1,1))
9251       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9252       vv(1)=pizda(1,1)-pizda(2,2)
9253       vv(2)=pizda(2,1)+pizda(1,2)
9254       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9255 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9256 #ifdef MOMENT
9257       eello6_graph4=-(s1+s2+s3+s4)
9258 #else
9259       eello6_graph4=-(s2+s3+s4)
9260 #endif
9261 C Derivatives in gamma(i-1)
9262       if (i.gt.1) then
9263 #ifdef MOMENT
9264         if (imat.eq.1) then
9265           s1=dipderg(2,jj,i)*dip(3,kk,k)
9266         else
9267           s1=dipderg(4,jj,j)*dip(2,kk,l)
9268         endif
9269 #endif
9270         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9271         if (j.eq.l+1) then
9272           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9273           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9274         else
9275           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9276           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9277         endif
9278         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9279         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9280 cd          write (2,*) 'turn6 derivatives'
9281 #ifdef MOMENT
9282           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9283 #else
9284           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9285 #endif
9286         else
9287 #ifdef MOMENT
9288           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9289 #else
9290           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9291 #endif
9292         endif
9293       endif
9294 C Derivatives in gamma(k-1)
9295 #ifdef MOMENT
9296       if (imat.eq.1) then
9297         s1=dip(3,jj,i)*dipderg(2,kk,k)
9298       else
9299         s1=dip(2,jj,j)*dipderg(4,kk,l)
9300       endif
9301 #endif
9302       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9303       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9304       if (j.eq.l+1) then
9305         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9306         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9307       else
9308         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9309         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9310       endif
9311       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9312       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9313       vv(1)=pizda(1,1)-pizda(2,2)
9314       vv(2)=pizda(2,1)+pizda(1,2)
9315       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9316       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9317 #ifdef MOMENT
9318         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9319 #else
9320         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9321 #endif
9322       else
9323 #ifdef MOMENT
9324         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9325 #else
9326         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9327 #endif
9328       endif
9329 C Derivatives in gamma(j-1) or gamma(l-1)
9330       if (l.eq.j+1 .and. l.gt.1) then
9331         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9332         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9333         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9334         vv(1)=pizda(1,1)-pizda(2,2)
9335         vv(2)=pizda(2,1)+pizda(1,2)
9336         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9337         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9338       else if (j.gt.1) then
9339         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9340         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9341         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9342         vv(1)=pizda(1,1)-pizda(2,2)
9343         vv(2)=pizda(2,1)+pizda(1,2)
9344         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9345         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9346           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9347         else
9348           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9349         endif
9350       endif
9351 C Cartesian derivatives.
9352       do iii=1,2
9353         do kkk=1,5
9354           do lll=1,3
9355 #ifdef MOMENT
9356             if (iii.eq.1) then
9357               if (imat.eq.1) then
9358                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9359               else
9360                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9361               endif
9362             else
9363               if (imat.eq.1) then
9364                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9365               else
9366                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9367               endif
9368             endif
9369 #endif
9370             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9371      &        auxvec(1))
9372             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9373             if (j.eq.l+1) then
9374               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9375      &          b1(1,j+1),auxvec(1))
9376               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9377             else
9378               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9379      &          b1(1,l+1),auxvec(1))
9380               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9381             endif
9382             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9383      &        pizda(1,1))
9384             vv(1)=pizda(1,1)-pizda(2,2)
9385             vv(2)=pizda(2,1)+pizda(1,2)
9386             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9387             if (swap) then
9388               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9389 #ifdef MOMENT
9390                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9391      &             -(s1+s2+s4)
9392 #else
9393                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9394      &             -(s2+s4)
9395 #endif
9396                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9397               else
9398 #ifdef MOMENT
9399                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9400 #else
9401                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9402 #endif
9403                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9404               endif
9405             else
9406 #ifdef MOMENT
9407               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9408 #else
9409               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9410 #endif
9411               if (l.eq.j+1) then
9412                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9413               else
9414                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9415               endif
9416             endif
9417           enddo
9418         enddo
9419       enddo
9420       return
9421       end
9422 c----------------------------------------------------------------------------
9423       double precision function eello_turn6(i,jj,kk)
9424       implicit real*8 (a-h,o-z)
9425       include 'DIMENSIONS'
9426       include 'COMMON.IOUNITS'
9427       include 'COMMON.CHAIN'
9428       include 'COMMON.DERIV'
9429       include 'COMMON.INTERACT'
9430       include 'COMMON.CONTACTS'
9431       include 'COMMON.TORSION'
9432       include 'COMMON.VAR'
9433       include 'COMMON.GEO'
9434       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9435      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9436      &  ggg1(3),ggg2(3)
9437       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9438      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9439 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9440 C           the respective energy moment and not to the cluster cumulant.
9441       s1=0.0d0
9442       s8=0.0d0
9443       s13=0.0d0
9444 c
9445       eello_turn6=0.0d0
9446       j=i+4
9447       k=i+1
9448       l=i+3
9449       iti=itortyp(itype(i))
9450       itk=itortyp(itype(k))
9451       itk1=itortyp(itype(k+1))
9452       itl=itortyp(itype(l))
9453       itj=itortyp(itype(j))
9454 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9455 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9456 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9457 cd        eello6=0.0d0
9458 cd        return
9459 cd      endif
9460 cd      write (iout,*)
9461 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9462 cd     &   ' and',k,l
9463 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9464       do iii=1,2
9465         do kkk=1,5
9466           do lll=1,3
9467             derx_turn(lll,kkk,iii)=0.0d0
9468           enddo
9469         enddo
9470       enddo
9471 cd      eij=1.0d0
9472 cd      ekl=1.0d0
9473 cd      ekont=1.0d0
9474       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9475 cd      eello6_5=0.0d0
9476 cd      write (2,*) 'eello6_5',eello6_5
9477 #ifdef MOMENT
9478       call transpose2(AEA(1,1,1),auxmat(1,1))
9479       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9480       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9481       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9482 #endif
9483       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9484       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9485       s2 = scalar2(b1(1,k),vtemp1(1))
9486 #ifdef MOMENT
9487       call transpose2(AEA(1,1,2),atemp(1,1))
9488       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9489       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9490       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9491 #endif
9492       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9493       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9494       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9495 #ifdef MOMENT
9496       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9497       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9498       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9499       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9500       ss13 = scalar2(b1(1,k),vtemp4(1))
9501       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9502 #endif
9503 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9504 c      s1=0.0d0
9505 c      s2=0.0d0
9506 c      s8=0.0d0
9507 c      s12=0.0d0
9508 c      s13=0.0d0
9509       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9510 C Derivatives in gamma(i+2)
9511       s1d =0.0d0
9512       s8d =0.0d0
9513 #ifdef MOMENT
9514       call transpose2(AEA(1,1,1),auxmatd(1,1))
9515       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9516       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9517       call transpose2(AEAderg(1,1,2),atempd(1,1))
9518       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9519       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9520 #endif
9521       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9522       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9523       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9524 c      s1d=0.0d0
9525 c      s2d=0.0d0
9526 c      s8d=0.0d0
9527 c      s12d=0.0d0
9528 c      s13d=0.0d0
9529       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9530 C Derivatives in gamma(i+3)
9531 #ifdef MOMENT
9532       call transpose2(AEA(1,1,1),auxmatd(1,1))
9533       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9534       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9535       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9536 #endif
9537       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9538       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9539       s2d = scalar2(b1(1,k),vtemp1d(1))
9540 #ifdef MOMENT
9541       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9542       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9543 #endif
9544       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9545 #ifdef MOMENT
9546       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9547       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9548       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9549 #endif
9550 c      s1d=0.0d0
9551 c      s2d=0.0d0
9552 c      s8d=0.0d0
9553 c      s12d=0.0d0
9554 c      s13d=0.0d0
9555 #ifdef MOMENT
9556       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9557      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9558 #else
9559       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9560      &               -0.5d0*ekont*(s2d+s12d)
9561 #endif
9562 C Derivatives in gamma(i+4)
9563       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9564       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9565       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9566 #ifdef MOMENT
9567       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9568       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9569       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9570 #endif
9571 c      s1d=0.0d0
9572 c      s2d=0.0d0
9573 c      s8d=0.0d0
9574 C      s12d=0.0d0
9575 c      s13d=0.0d0
9576 #ifdef MOMENT
9577       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9578 #else
9579       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9580 #endif
9581 C Derivatives in gamma(i+5)
9582 #ifdef MOMENT
9583       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9584       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9585       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9586 #endif
9587       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9588       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9589       s2d = scalar2(b1(1,k),vtemp1d(1))
9590 #ifdef MOMENT
9591       call transpose2(AEA(1,1,2),atempd(1,1))
9592       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9593       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9594 #endif
9595       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9596       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9597 #ifdef MOMENT
9598       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9599       ss13d = scalar2(b1(1,k),vtemp4d(1))
9600       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9601 #endif
9602 c      s1d=0.0d0
9603 c      s2d=0.0d0
9604 c      s8d=0.0d0
9605 c      s12d=0.0d0
9606 c      s13d=0.0d0
9607 #ifdef MOMENT
9608       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9609      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9610 #else
9611       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9612      &               -0.5d0*ekont*(s2d+s12d)
9613 #endif
9614 C Cartesian derivatives
9615       do iii=1,2
9616         do kkk=1,5
9617           do lll=1,3
9618 #ifdef MOMENT
9619             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9620             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9621             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9622 #endif
9623             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9624             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9625      &          vtemp1d(1))
9626             s2d = scalar2(b1(1,k),vtemp1d(1))
9627 #ifdef MOMENT
9628             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9629             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9630             s8d = -(atempd(1,1)+atempd(2,2))*
9631      &           scalar2(cc(1,1,itl),vtemp2(1))
9632 #endif
9633             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9634      &           auxmatd(1,1))
9635             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9636             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9637 c      s1d=0.0d0
9638 c      s2d=0.0d0
9639 c      s8d=0.0d0
9640 c      s12d=0.0d0
9641 c      s13d=0.0d0
9642 #ifdef MOMENT
9643             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9644      &        - 0.5d0*(s1d+s2d)
9645 #else
9646             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9647      &        - 0.5d0*s2d
9648 #endif
9649 #ifdef MOMENT
9650             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9651      &        - 0.5d0*(s8d+s12d)
9652 #else
9653             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9654      &        - 0.5d0*s12d
9655 #endif
9656           enddo
9657         enddo
9658       enddo
9659 #ifdef MOMENT
9660       do kkk=1,5
9661         do lll=1,3
9662           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9663      &      achuj_tempd(1,1))
9664           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9665           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9666           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9667           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9668           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9669      &      vtemp4d(1))
9670           ss13d = scalar2(b1(1,k),vtemp4d(1))
9671           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9672           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9673         enddo
9674       enddo
9675 #endif
9676 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9677 cd     &  16*eel_turn6_num
9678 cd      goto 1112
9679       if (j.lt.nres-1) then
9680         j1=j+1
9681         j2=j-1
9682       else
9683         j1=j-1
9684         j2=j-2
9685       endif
9686       if (l.lt.nres-1) then
9687         l1=l+1
9688         l2=l-1
9689       else
9690         l1=l-1
9691         l2=l-2
9692       endif
9693       do ll=1,3
9694 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9695 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9696 cgrad        ghalf=0.5d0*ggg1(ll)
9697 cd        ghalf=0.0d0
9698         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9699         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9700         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9701      &    +ekont*derx_turn(ll,2,1)
9702         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9703         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9704      &    +ekont*derx_turn(ll,4,1)
9705         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9706         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9707         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9708 cgrad        ghalf=0.5d0*ggg2(ll)
9709 cd        ghalf=0.0d0
9710         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9711      &    +ekont*derx_turn(ll,2,2)
9712         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9713         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9714      &    +ekont*derx_turn(ll,4,2)
9715         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9716         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9717         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9718       enddo
9719 cd      goto 1112
9720 cgrad      do m=i+1,j-1
9721 cgrad        do ll=1,3
9722 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9723 cgrad        enddo
9724 cgrad      enddo
9725 cgrad      do m=k+1,l-1
9726 cgrad        do ll=1,3
9727 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9728 cgrad        enddo
9729 cgrad      enddo
9730 cgrad1112  continue
9731 cgrad      do m=i+2,j2
9732 cgrad        do ll=1,3
9733 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9734 cgrad        enddo
9735 cgrad      enddo
9736 cgrad      do m=k+2,l2
9737 cgrad        do ll=1,3
9738 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9739 cgrad        enddo
9740 cgrad      enddo
9741 cd      do iii=1,nres-3
9742 cd        write (2,*) iii,g_corr6_loc(iii)
9743 cd      enddo
9744       eello_turn6=ekont*eel_turn6
9745 cd      write (2,*) 'ekont',ekont
9746 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9747       return
9748       end
9749
9750 C-----------------------------------------------------------------------------
9751       double precision function scalar(u,v)
9752 !DIR$ INLINEALWAYS scalar
9753 #ifndef OSF
9754 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9755 #endif
9756       implicit none
9757       double precision u(3),v(3)
9758 cd      double precision sc
9759 cd      integer i
9760 cd      sc=0.0d0
9761 cd      do i=1,3
9762 cd        sc=sc+u(i)*v(i)
9763 cd      enddo
9764 cd      scalar=sc
9765
9766       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9767       return
9768       end
9769 crc-------------------------------------------------
9770       SUBROUTINE MATVEC2(A1,V1,V2)
9771 !DIR$ INLINEALWAYS MATVEC2
9772 #ifndef OSF
9773 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9774 #endif
9775       implicit real*8 (a-h,o-z)
9776       include 'DIMENSIONS'
9777       DIMENSION A1(2,2),V1(2),V2(2)
9778 c      DO 1 I=1,2
9779 c        VI=0.0
9780 c        DO 3 K=1,2
9781 c    3     VI=VI+A1(I,K)*V1(K)
9782 c        Vaux(I)=VI
9783 c    1 CONTINUE
9784
9785       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9786       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9787
9788       v2(1)=vaux1
9789       v2(2)=vaux2
9790       END
9791 C---------------------------------------
9792       SUBROUTINE MATMAT2(A1,A2,A3)
9793 #ifndef OSF
9794 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9795 #endif
9796       implicit real*8 (a-h,o-z)
9797       include 'DIMENSIONS'
9798       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9799 c      DIMENSION AI3(2,2)
9800 c        DO  J=1,2
9801 c          A3IJ=0.0
9802 c          DO K=1,2
9803 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9804 c          enddo
9805 c          A3(I,J)=A3IJ
9806 c       enddo
9807 c      enddo
9808
9809       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9810       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9811       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9812       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9813
9814       A3(1,1)=AI3_11
9815       A3(2,1)=AI3_21
9816       A3(1,2)=AI3_12
9817       A3(2,2)=AI3_22
9818       END
9819
9820 c-------------------------------------------------------------------------
9821       double precision function scalar2(u,v)
9822 !DIR$ INLINEALWAYS scalar2
9823       implicit none
9824       double precision u(2),v(2)
9825       double precision sc
9826       integer i
9827       scalar2=u(1)*v(1)+u(2)*v(2)
9828       return
9829       end
9830
9831 C-----------------------------------------------------------------------------
9832
9833       subroutine transpose2(a,at)
9834 !DIR$ INLINEALWAYS transpose2
9835 #ifndef OSF
9836 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9837 #endif
9838       implicit none
9839       double precision a(2,2),at(2,2)
9840       at(1,1)=a(1,1)
9841       at(1,2)=a(2,1)
9842       at(2,1)=a(1,2)
9843       at(2,2)=a(2,2)
9844       return
9845       end
9846 c--------------------------------------------------------------------------
9847       subroutine transpose(n,a,at)
9848       implicit none
9849       integer n,i,j
9850       double precision a(n,n),at(n,n)
9851       do i=1,n
9852         do j=1,n
9853           at(j,i)=a(i,j)
9854         enddo
9855       enddo
9856       return
9857       end
9858 C---------------------------------------------------------------------------
9859       subroutine prodmat3(a1,a2,kk,transp,prod)
9860 !DIR$ INLINEALWAYS prodmat3
9861 #ifndef OSF
9862 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9863 #endif
9864       implicit none
9865       integer i,j
9866       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9867       logical transp
9868 crc      double precision auxmat(2,2),prod_(2,2)
9869
9870       if (transp) then
9871 crc        call transpose2(kk(1,1),auxmat(1,1))
9872 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9873 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9874
9875            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9876      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9877            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9878      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9879            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9880      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9881            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9882      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9883
9884       else
9885 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9886 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9887
9888            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9889      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9890            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9891      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9892            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9893      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9894            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9895      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9896
9897       endif
9898 c      call transpose2(a2(1,1),a2t(1,1))
9899
9900 crc      print *,transp
9901 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9902 crc      print *,((prod(i,j),i=1,2),j=1,2)
9903
9904       return
9905       end
9906