source/unres/src_MD-M-newcorr/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 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 C      if (dyn_ss) call dyn_set_nss
 128 c      print *,"Processor",myrank," computed USCSC"
 129 #ifdef TIMING
 130       time01=MPI_Wtime()
 131 #endif
 132       call vec_and_deriv
 133 #ifdef TIMING
 134       time_vec=time_vec+MPI_Wtime()-time01
 135 #endif
 136 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 137       if (ipot.lt.6) then
 138 #ifdef SPLITELE
 139          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 140      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 141      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 142      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 143 #else
 144          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 145      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 146      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 147      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 148 #endif
 149             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 150          else
 151             ees=0.0d0
 152             evdw1=0.0d0
 153             eel_loc=0.0d0
 154             eello_turn3=0.0d0
 155             eello_turn4=0.0d0
 156          endif
 157       else
 158 c        write (iout,*) "Soft-spheer ELEC potential"
 159         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 160      &   eello_turn4)
 161       endif
 162 c      print *,"Processor",myrank," computed UELEC"
 163 C
 164 C Calculate excluded-volume interaction energy between peptide groups
 165 C and side chains.
 166 C
 167       if (ipot.lt.6) then
 168        if(wscp.gt.0d0) then
 169         call escp(evdw2,evdw2_14)
 170        else
 171         evdw2=0
 172         evdw2_14=0
 173        endif
 174       else
 175 c        write (iout,*) "Soft-sphere SCP potential"
 176         call escp_soft_sphere(evdw2,evdw2_14)
 177       endif
 178 c
 179 c Calculate the bond-stretching energy
 180 c
 181       call ebond(estr)
 182 C
 183 C Calculate the disulfide-bridge and other energy and the contributions
 184 C from other distance constraints.
 185 cd    print *,'Calling EHPB'
 186       call edis(ehpb)
 187 cd    print *,'EHPB exitted succesfully.'
 188 C
 189 C Calculate the virtual-bond-angle energy.
 190 C
 191       if (wang.gt.0d0) then
 192         call ebend(ebe)
 193       else
 194         ebe=0
 195       endif
 196 c      print *,"Processor",myrank," computed UB"
 197 C
 198 C Calculate the SC local energy.
 199 C
 200       call esc(escloc)
 201 c      print *,"Processor",myrank," computed USC"
 202 C
 203 C Calculate the virtual-bond torsional energy.
 204 C
 205 cd    print *,'nterm=',nterm
 206       if (wtor.gt.0) then
 207        call etor(etors,edihcnstr)
 208       else
 209        etors=0
 210        edihcnstr=0
 211       endif
 212 c      print *,"Processor",myrank," computed Utor"
 213 C
 214 C 6/23/01 Calculate double-torsional energy
 215 C
 216       if (wtor_d.gt.0) then
 217        call etor_d(etors_d)
 218       else
 219        etors_d=0
 220       endif
 221 c      print *,"Processor",myrank," computed Utord"
 222 C
 223 C 21/5/07 Calculate local sicdechain correlation energy
 224 C
 225       if (wsccor.gt.0.0d0) then
 226         call eback_sc_corr(esccor)
 227       else
 228         esccor=0.0d0
 229       endif
 230 c      print *,"Processor",myrank," computed Usccorr"
 231 C
 232 C 12/1/95 Multi-body terms
 233 C
 234       n_corr=0
 235       n_corr1=0
 236       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 237      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 238          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 239 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 240 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 241       else
 242          ecorr=0.0d0
 243          ecorr5=0.0d0
 244          ecorr6=0.0d0
 245          eturn6=0.0d0
 246       endif
 247       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 248          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 249 cd         write (iout,*) "multibody_hb ecorr",ecorr
 250       endif
 251 c      print *,"Processor",myrank," computed Ucorr"
 252 C
 253 C If performing constraint dynamics, call the constraint energy
 254 C  after the equilibration time
 255       if(usampl.and.totT.gt.eq_time) then
 256          call EconstrQ
 257          call Econstr_back
 258       else
 259          Uconst=0.0d0
 260          Uconst_back=0.0d0
 261       endif
 262 #ifdef TIMING
 263       time_enecalc=time_enecalc+MPI_Wtime()-time00
 264 #endif
 265 c      print *,"Processor",myrank," computed Uconstr"
 266 #ifdef TIMING
 267       time00=MPI_Wtime()
 268 #endif
 269 c
 270 C Sum the energies
 271 C
 272       energia(1)=evdw
 273 #ifdef SCP14
 274       energia(2)=evdw2-evdw2_14
 275       energia(18)=evdw2_14
 276 #else
 277       energia(2)=evdw2
 278       energia(18)=0.0d0
 279 #endif
 280 #ifdef SPLITELE
 281       energia(3)=ees
 282       energia(16)=evdw1
 283 #else
 284       energia(3)=ees+evdw1
 285       energia(16)=0.0d0
 286 #endif
 287       energia(4)=ecorr
 288       energia(5)=ecorr5
 289       energia(6)=ecorr6
 290       energia(7)=eel_loc
 291       energia(8)=eello_turn3
 292       energia(9)=eello_turn4
 293       energia(10)=eturn6
 294       energia(11)=ebe
 295       energia(12)=escloc
 296       energia(13)=etors
 297       energia(14)=etors_d
 298       energia(15)=ehpb
 299       energia(19)=edihcnstr
 300       energia(17)=estr
 301       energia(20)=Uconst+Uconst_back
 302       energia(21)=esccor
 303 c    Here are the energies showed per procesor if the are more processors
 304 c    per molecule then we sum it up in sum_energy subroutine
 305 c      print *," Processor",myrank," calls SUM_ENERGY"
 306       call sum_energy(energia,.true.)
 307       if (dyn_ss) call dyn_set_nss
 308 c      print *," Processor",myrank," left SUM_ENERGY"
 309 #ifdef TIMING
 310       time_sumene=time_sumene+MPI_Wtime()-time00
 311 #endif
 312       return
 313       end
 314 c-------------------------------------------------------------------------------
 315       subroutine sum_energy(energia,reduce)
 316       implicit real*8 (a-h,o-z)
 317       include 'DIMENSIONS'
 318 #ifndef ISNAN
 319       external proc_proc
 320 #ifdef WINPGI
 321 cMS$ATTRIBUTES C ::  proc_proc
 322 #endif
 323 #endif
 324 #ifdef MPI
 325       include "mpif.h"
 326 #endif
 327       include 'COMMON.SETUP'
 328       include 'COMMON.IOUNITS'
 329       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 330       include 'COMMON.FFIELD'
 331       include 'COMMON.DERIV'
 332       include 'COMMON.INTERACT'
 333       include 'COMMON.SBRIDGE'
 334       include 'COMMON.CHAIN'
 335       include 'COMMON.VAR'
 336       include 'COMMON.CONTROL'
 337       include 'COMMON.TIME1'
 338       logical reduce
 339 #ifdef MPI
 340       if (nfgtasks.gt.1 .and. reduce) then
 341 #ifdef DEBUG
 342         write (iout,*) "energies before REDUCE"
 343         call enerprint(energia)
 344         call flush(iout)
 345 #endif
 346         do i=0,n_ene
 347           enebuff(i)=energia(i)
 348         enddo
 349         time00=MPI_Wtime()
 350         call MPI_Barrier(FG_COMM,IERR)
 351         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 352         time00=MPI_Wtime()
 353         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 354      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 355 #ifdef DEBUG
 356         write (iout,*) "energies after REDUCE"
 357         call enerprint(energia)
 358         call flush(iout)
 359 #endif
 360         time_Reduce=time_Reduce+MPI_Wtime()-time00
 361       endif
 362       if (fg_rank.eq.0) then
 363 #endif
 364       evdw=energia(1)
 365 #ifdef SCP14
 366       evdw2=energia(2)+energia(18)
 367       evdw2_14=energia(18)
 368 #else
 369       evdw2=energia(2)
 370 #endif
 371 #ifdef SPLITELE
 372       ees=energia(3)
 373       evdw1=energia(16)
 374 #else
 375       ees=energia(3)
 376       evdw1=0.0d0
 377 #endif
 378       ecorr=energia(4)
 379       ecorr5=energia(5)
 380       ecorr6=energia(6)
 381       eel_loc=energia(7)
 382       eello_turn3=energia(8)
 383       eello_turn4=energia(9)
 384       eturn6=energia(10)
 385       ebe=energia(11)
 386       escloc=energia(12)
 387       etors=energia(13)
 388       etors_d=energia(14)
 389       ehpb=energia(15)
 390       edihcnstr=energia(19)
 391       estr=energia(17)
 392       Uconst=energia(20)
 393       esccor=energia(21)
 394 #ifdef SPLITELE
 395       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 396      & +wang*ebe+wtor*etors+wscloc*escloc
 397      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 398      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 399      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 400      & +wbond*estr+Uconst+wsccor*esccor
 401 #else
 402       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 403      & +wang*ebe+wtor*etors+wscloc*escloc
 404      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 405      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 406      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 407      & +wbond*estr+Uconst+wsccor*esccor
 408 #endif
 409       energia(0)=etot
 410 c detecting NaNQ
 411 #ifdef ISNAN
 412 #ifdef AIX
 413       if (isnan(etot).ne.0) energia(0)=1.0d+99
 414 #else
 415       if (isnan(etot)) energia(0)=1.0d+99
 416 #endif
 417 #else
 418       i=0
 419 #ifdef WINPGI
 420       idumm=proc_proc(etot,i)
 421 #else
 422       call proc_proc(etot,i)
 423 #endif
 424       if(i.eq.1)energia(0)=1.0d+99
 425 #endif
 426 #ifdef MPI
 427       endif
 428 #endif
 429       return
 430       end
 431 c-------------------------------------------------------------------------------
 432       subroutine sum_gradient
 433       implicit real*8 (a-h,o-z)
 434       include 'DIMENSIONS'
 435 #ifndef ISNAN
 436       external proc_proc
 437 #ifdef WINPGI
 438 cMS$ATTRIBUTES C ::  proc_proc
 439 #endif
 440 #endif
 441 #ifdef MPI
 442       include 'mpif.h'
 443       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 444      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 445 #endif
 446       include 'COMMON.SETUP'
 447       include 'COMMON.IOUNITS'
 448       include 'COMMON.FFIELD'
 449       include 'COMMON.DERIV'
 450       include 'COMMON.INTERACT'
 451       include 'COMMON.SBRIDGE'
 452       include 'COMMON.CHAIN'
 453       include 'COMMON.VAR'
 454       include 'COMMON.CONTROL'
 455       include 'COMMON.TIME1'
 456       include 'COMMON.MAXGRAD'
 457       include 'COMMON.SCCOR'
 458 #ifdef TIMING
 459       time01=MPI_Wtime()
 460 #endif
 461 #ifdef DEBUG
 462       write (iout,*) "sum_gradient gvdwc, gvdwx"
 463       do i=1,nres
 464         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 465      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 466       enddo
 467       call flush(iout)
 468 #endif
 469 #ifdef MPI
 470 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 471         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 472      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 473 #endif
 474 C
 475 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 476 C            in virtual-bond-vector coordinates
 477 C
 478 #ifdef DEBUG
 479 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 482 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 483 c      enddo
 484 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 485 c      do i=1,nres-1
 486 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 487 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 488 c      enddo
 489       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 490       do i=1,nres
 491         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 492      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 493      &   g_corr5_loc(i)
 494       enddo
 495       call flush(iout)
 496 #endif
 497 #ifdef SPLITELE
 498       do i=1,nct
 499         do j=1,3
 500           gradbufc(j,i)=wsc*gvdwc(j,i)+
 501      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 502      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 503      &                wel_loc*gel_loc_long(j,i)+
 504      &                wcorr*gradcorr_long(j,i)+
 505      &                wcorr5*gradcorr5_long(j,i)+
 506      &                wcorr6*gradcorr6_long(j,i)+
 507      &                wturn6*gcorr6_turn_long(j,i)+
 508      &                wstrain*ghpbc(j,i)
 509         enddo
 510       enddo
 511 #else
 512       do i=1,nct
 513         do j=1,3
 514           gradbufc(j,i)=wsc*gvdwc(j,i)+
 515      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 516      &                welec*gelc_long(j,i)+
 517      &                wbond*gradb(j,i)+
 518      &                wel_loc*gel_loc_long(j,i)+
 519      &                wcorr*gradcorr_long(j,i)+
 520      &                wcorr5*gradcorr5_long(j,i)+
 521      &                wcorr6*gradcorr6_long(j,i)+
 522      &                wturn6*gcorr6_turn_long(j,i)+
 523      &                wstrain*ghpbc(j,i)
 524         enddo
 525       enddo
 526 #endif
 527 #ifdef MPI
 528       if (nfgtasks.gt.1) then
 529       time00=MPI_Wtime()
 530 #ifdef DEBUG
 531       write (iout,*) "gradbufc before allreduce"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 534       enddo
 535       call flush(iout)
 536 #endif
 537       do i=1,nres
 538         do j=1,3
 539           gradbufc_sum(j,i)=gradbufc(j,i)
 540         enddo
 541       enddo
 542 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 543 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 544 c      time_reduce=time_reduce+MPI_Wtime()-time00
 545 #ifdef DEBUG
 546 c      write (iout,*) "gradbufc_sum after allreduce"
 547 c      do i=1,nres
 548 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 549 c      enddo
 550 c      call flush(iout)
 551 #endif
 552 #ifdef TIMING
 553 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 554 #endif
 555       do i=nnt,nres
 556         do k=1,3
 557           gradbufc(k,i)=0.0d0
 558         enddo
 559       enddo
 560 #ifdef DEBUG
 561       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 562       write (iout,*) (i," jgrad_start",jgrad_start(i),
 563      &                  " jgrad_end  ",jgrad_end(i),
 564      &                  i=igrad_start,igrad_end)
 565 #endif
 566 c
 567 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 568 c do not parallelize this part.
 569 c
 570 c      do i=igrad_start,igrad_end
 571 c        do j=jgrad_start(i),jgrad_end(i)
 572 c          do k=1,3
 573 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 574 c          enddo
 575 c        enddo
 576 c      enddo
 577       do j=1,3
 578         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 579       enddo
 580       do i=nres-2,nnt,-1
 581         do j=1,3
 582           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 583         enddo
 584       enddo
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc after summing"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       else
 593 #endif
 594 #ifdef DEBUG
 595       write (iout,*) "gradbufc"
 596       do i=1,nres
 597         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 598       enddo
 599       call flush(iout)
 600 #endif
 601       do i=1,nres
 602         do j=1,3
 603           gradbufc_sum(j,i)=gradbufc(j,i)
 604           gradbufc(j,i)=0.0d0
 605         enddo
 606       enddo
 607       do j=1,3
 608         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 609       enddo
 610       do i=nres-2,nnt,-1
 611         do j=1,3
 612           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 613         enddo
 614       enddo
 615 c      do i=nnt,nres-1
 616 c        do k=1,3
 617 c          gradbufc(k,i)=0.0d0
 618 c        enddo
 619 c        do j=i+1,nres
 620 c          do k=1,3
 621 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 622 c          enddo
 623 c        enddo
 624 c      enddo
 625 #ifdef DEBUG
 626       write (iout,*) "gradbufc after summing"
 627       do i=1,nres
 628         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632 #ifdef MPI
 633       endif
 634 #endif
 635       do k=1,3
 636         gradbufc(k,nres)=0.0d0
 637       enddo
 638       do i=1,nct
 639         do j=1,3
 640 #ifdef SPLITELE
 641           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 642      &                wel_loc*gel_loc(j,i)+
 643      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 644      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 645      &                wel_loc*gel_loc_long(j,i)+
 646      &                wcorr*gradcorr_long(j,i)+
 647      &                wcorr5*gradcorr5_long(j,i)+
 648      &                wcorr6*gradcorr6_long(j,i)+
 649      &                wturn6*gcorr6_turn_long(j,i))+
 650      &                wbond*gradb(j,i)+
 651      &                wcorr*gradcorr(j,i)+
 652      &                wturn3*gcorr3_turn(j,i)+
 653      &                wturn4*gcorr4_turn(j,i)+
 654      &                wcorr5*gradcorr5(j,i)+
 655      &                wcorr6*gradcorr6(j,i)+
 656      &                wturn6*gcorr6_turn(j,i)+
 657      &                wsccor*gsccorc(j,i)
 658      &               +wscloc*gscloc(j,i)
 659 #else
 660           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 661      &                wel_loc*gel_loc(j,i)+
 662      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 663      &                welec*gelc_long(j,i)
 664      &                wel_loc*gel_loc_long(j,i)+
 665      &                wcorr*gcorr_long(j,i)+
 666      &                wcorr5*gradcorr5_long(j,i)+
 667      &                wcorr6*gradcorr6_long(j,i)+
 668      &                wturn6*gcorr6_turn_long(j,i))+
 669      &                wbond*gradb(j,i)+
 670      &                wcorr*gradcorr(j,i)+
 671      &                wturn3*gcorr3_turn(j,i)+
 672      &                wturn4*gcorr4_turn(j,i)+
 673      &                wcorr5*gradcorr5(j,i)+
 674      &                wcorr6*gradcorr6(j,i)+
 675      &                wturn6*gcorr6_turn(j,i)+
 676      &                wsccor*gsccorc(j,i)
 677      &               +wscloc*gscloc(j,i)
 678 #endif
 679           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 680      &                  wbond*gradbx(j,i)+
 681      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 682      &                  wsccor*gsccorx(j,i)
 683      &                 +wscloc*gsclocx(j,i)
 684         enddo
 685       enddo
 686 #ifdef DEBUG
 687       write (iout,*) "gloc before adding corr"
 688       do i=1,4*nres
 689         write (iout,*) i,gloc(i,icg)
 690       enddo
 691 #endif
 692       do i=1,nres-3
 693         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 694      &   +wcorr5*g_corr5_loc(i)
 695      &   +wcorr6*g_corr6_loc(i)
 696      &   +wturn4*gel_loc_turn4(i)
 697      &   +wturn3*gel_loc_turn3(i)
 698      &   +wturn6*gel_loc_turn6(i)
 699      &   +wel_loc*gel_loc_loc(i)
 700       enddo
 701 #ifdef DEBUG
 702       write (iout,*) "gloc after adding corr"
 703       do i=1,4*nres
 704         write (iout,*) i,gloc(i,icg)
 705       enddo
 706 #endif
 707 #ifdef MPI
 708       if (nfgtasks.gt.1) then
 709         do j=1,3
 710           do i=1,nres
 711             gradbufc(j,i)=gradc(j,i,icg)
 712             gradbufx(j,i)=gradx(j,i,icg)
 713           enddo
 714         enddo
 715         do i=1,4*nres
 716           glocbuf(i)=gloc(i,icg)
 717         enddo
 718 #define DEBUG
 719 #ifdef DEBUG
 720       write (iout,*) "gloc_sc before reduce"
 721       do i=1,nres
 722        do j=1,1
 723         write (iout,*) i,j,gloc_sc(j,i,icg)
 724        enddo
 725       enddo
 726 #endif
 727 #undef DEBUG
 728         do i=1,nres
 729          do j=1,3
 730           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 731          enddo
 732         enddo
 733         time00=MPI_Wtime()
 734         call MPI_Barrier(FG_COMM,IERR)
 735         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 736         time00=MPI_Wtime()
 737         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         time_reduce=time_reduce+MPI_Wtime()-time00
 744         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 746         time_reduce=time_reduce+MPI_Wtime()-time00
 747 #define DEBUG
 748 #ifdef DEBUG
 749       write (iout,*) "gloc_sc after reduce"
 750       do i=1,nres
 751        do j=1,1
 752         write (iout,*) i,j,gloc_sc(j,i,icg)
 753        enddo
 754       enddo
 755 #endif
 756 #undef DEBUG
 757 #ifdef DEBUG
 758       write (iout,*) "gloc after reduce"
 759       do i=1,4*nres
 760         write (iout,*) i,gloc(i,icg)
 761       enddo
 762 #endif
 763       endif
 764 #endif
 765       if (gnorm_check) then
 766 c
 767 c Compute the maximum elements of the gradient
 768 c
 769       gvdwc_max=0.0d0
 770       gvdwc_scp_max=0.0d0
 771       gelc_max=0.0d0
 772       gvdwpp_max=0.0d0
 773       gradb_max=0.0d0
 774       ghpbc_max=0.0d0
 775       gradcorr_max=0.0d0
 776       gel_loc_max=0.0d0
 777       gcorr3_turn_max=0.0d0
 778       gcorr4_turn_max=0.0d0
 779       gradcorr5_max=0.0d0
 780       gradcorr6_max=0.0d0
 781       gcorr6_turn_max=0.0d0
 782       gsccorc_max=0.0d0
 783       gscloc_max=0.0d0
 784       gvdwx_max=0.0d0
 785       gradx_scp_max=0.0d0
 786       ghpbx_max=0.0d0
 787       gradxorr_max=0.0d0
 788       gsccorx_max=0.0d0
 789       gsclocx_max=0.0d0
 790       do i=1,nct
 791         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 792         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 793         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 794         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 795      &   gvdwc_scp_max=gvdwc_scp_norm
 796         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 797         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 798         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 799         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 800         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 801         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 802         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 803         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 804         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 805         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 806         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 807         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 808         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 809      &    gcorr3_turn(1,i)))
 810         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 811      &    gcorr3_turn_max=gcorr3_turn_norm
 812         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 813      &    gcorr4_turn(1,i)))
 814         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 815      &    gcorr4_turn_max=gcorr4_turn_norm
 816         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 817         if (gradcorr5_norm.gt.gradcorr5_max)
 818      &    gradcorr5_max=gradcorr5_norm
 819         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 820         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 821         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 822      &    gcorr6_turn(1,i)))
 823         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 824      &    gcorr6_turn_max=gcorr6_turn_norm
 825         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 826         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 827         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 828         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 829         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 830         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 831         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 832         if (gradx_scp_norm.gt.gradx_scp_max)
 833      &    gradx_scp_max=gradx_scp_norm
 834         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 835         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 836         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 837         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 838         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 839         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 840         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 841         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 842       enddo
 843       if (gradout) then
 844 #ifdef AIX
 845         open(istat,file=statname,position="append")
 846 #else
 847         open(istat,file=statname,access="append")
 848 #endif
 849         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 850      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 851      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 852      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 853      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 854      &     gsccorx_max,gsclocx_max
 855         close(istat)
 856         if (gvdwc_max.gt.1.0d4) then
 857           write (iout,*) "gvdwc gvdwx gradb gradbx"
 858           do i=nnt,nct
 859             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 860      &        gradb(j,i),gradbx(j,i),j=1,3)
 861           enddo
 862           call pdbout(0.0d0,'cipiszcze',iout)
 863           call flush(iout)
 864         endif
 865       endif
 866       endif
 867 #ifdef DEBUG
 868       write (iout,*) "gradc gradx gloc"
 869       do i=1,nres
 870         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 871      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 872       enddo
 873 #endif
 874 #ifdef TIMING
 875       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 876 #endif
 877       return
 878       end
 879 c-------------------------------------------------------------------------------
 880       subroutine rescale_weights(t_bath)
 881       implicit real*8 (a-h,o-z)
 882       include 'DIMENSIONS'
 883       include 'COMMON.IOUNITS'
 884       include 'COMMON.FFIELD'
 885       include 'COMMON.SBRIDGE'
 886       double precision kfac /2.4d0/
 887       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 888 c      facT=temp0/t_bath
 889 c      facT=2*temp0/(t_bath+temp0)
 890       if (rescale_mode.eq.0) then
 891         facT=1.0d0
 892         facT2=1.0d0
 893         facT3=1.0d0
 894         facT4=1.0d0
 895         facT5=1.0d0
 896       else if (rescale_mode.eq.1) then
 897         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 898         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 899         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 900         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 901         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 902       else if (rescale_mode.eq.2) then
 903         x=t_bath/temp0
 904         x2=x*x
 905         x3=x2*x
 906         x4=x3*x
 907         x5=x4*x
 908         facT=licznik/dlog(dexp(x)+dexp(-x))
 909         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 910         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 911         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 912         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 913       else
 914         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 915         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 916 #ifdef MPI
 917        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 918 #endif
 919        stop 555
 920       endif
 921       welec=weights(3)*fact
 922       wcorr=weights(4)*fact3
 923       wcorr5=weights(5)*fact4
 924       wcorr6=weights(6)*fact5
 925       wel_loc=weights(7)*fact2
 926       wturn3=weights(8)*fact2
 927       wturn4=weights(9)*fact3
 928       wturn6=weights(10)*fact5
 929       wtor=weights(13)*fact
 930       wtor_d=weights(14)*fact2
 931       wsccor=weights(21)*fact
 932
 933       return
 934       end
 935 C------------------------------------------------------------------------
 936       subroutine enerprint(energia)
 937       implicit real*8 (a-h,o-z)
 938       include 'DIMENSIONS'
 939       include 'COMMON.IOUNITS'
 940       include 'COMMON.FFIELD'
 941       include 'COMMON.SBRIDGE'
 942       include 'COMMON.MD'
 943       double precision energia(0:n_ene)
 944       etot=energia(0)
 945       evdw=energia(1)
 946       evdw2=energia(2)
 947 #ifdef SCP14
 948       evdw2=energia(2)+energia(18)
 949 #else
 950       evdw2=energia(2)
 951 #endif
 952       ees=energia(3)
 953 #ifdef SPLITELE
 954       evdw1=energia(16)
 955 #endif
 956       ecorr=energia(4)
 957       ecorr5=energia(5)
 958       ecorr6=energia(6)
 959       eel_loc=energia(7)
 960       eello_turn3=energia(8)
 961       eello_turn4=energia(9)
 962       eello_turn6=energia(10)
 963       ebe=energia(11)
 964       escloc=energia(12)
 965       etors=energia(13)
 966       etors_d=energia(14)
 967       ehpb=energia(15)
 968       edihcnstr=energia(19)
 969       estr=energia(17)
 970       Uconst=energia(20)
 971       esccor=energia(21)
 972 #ifdef SPLITELE
 973       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 974      &  estr,wbond,ebe,wang,
 975      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 976      &  ecorr,wcorr,
 977      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 978      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 979      &  edihcnstr,ebr*nss,
 980      &  Uconst,etot
 981    10 format (/'Virtual-chain energies:'//
 982      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 983      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 984      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 985      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 986      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 987      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 988      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 989      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 990      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 991      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 992      & ' (SS bridges & dist. cnstr.)'/
 993      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 994      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 997      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 998      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 999      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1000      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1001      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1002      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1003      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1004      & 'ETOT=  ',1pE16.6,' (total)')
1005 #else
1006       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1007      &  estr,wbond,ebe,wang,
1008      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1009      &  ecorr,wcorr,
1010      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1011      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1012      &  ebr*nss,Uconst,etot
1013    10 format (/'Virtual-chain energies:'//
1014      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1015      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1016      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1017      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1018      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1019      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1020      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1021      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1022      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1023      & ' (SS bridges & dist. cnstr.)'/
1024      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1025      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1028      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1029      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1030      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1031      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1032      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1033      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1034      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1035      & 'ETOT=  ',1pE16.6,' (total)')
1036 #endif
1037       return
1038       end
1039 C-----------------------------------------------------------------------
1040       subroutine elj(evdw)
1041 C
1042 C This subroutine calculates the interaction energy of nonbonded side chains
1043 C assuming the LJ potential of interaction.
1044 C
1045       implicit real*8 (a-h,o-z)
1046       include 'DIMENSIONS'
1047       parameter (accur=1.0d-10)
1048       include 'COMMON.GEO'
1049       include 'COMMON.VAR'
1050       include 'COMMON.LOCAL'
1051       include 'COMMON.CHAIN'
1052       include 'COMMON.DERIV'
1053       include 'COMMON.INTERACT'
1054       include 'COMMON.TORSION'
1055       include 'COMMON.SBRIDGE'
1056       include 'COMMON.NAMES'
1057       include 'COMMON.IOUNITS'
1058       include 'COMMON.CONTACTS'
1059       dimension gg(3)
1060 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1061       evdw=0.0D0
1062       do i=iatsc_s,iatsc_e
1063         itypi=iabs(itype(i))
1064         if (itypi.eq.ntyp1) cycle
1065         itypi1=iabs(itype(i+1))
1066         xi=c(1,nres+i)
1067         yi=c(2,nres+i)
1068         zi=c(3,nres+i)
1069 C Change 12/1/95
1070         num_conti=0
1071 C
1072 C Calculate SC interaction energy.
1073 C
1074         do iint=1,nint_gr(i)
1075 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1076 cd   &                  'iend=',iend(i,iint)
1077           do j=istart(i,iint),iend(i,iint)
1078             itypj=iabs(itype(j))
1079             if (itypj.eq.ntyp1) cycle
1080             xj=c(1,nres+j)-xi
1081             yj=c(2,nres+j)-yi
1082             zj=c(3,nres+j)-zi
1083 C Change 12/1/95 to calculate four-body interactions
1084             rij=xj*xj+yj*yj+zj*zj
1085             rrij=1.0D0/rij
1086 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1087             eps0ij=eps(itypi,itypj)
1088             fac=rrij**expon2
1089             e1=fac*fac*aa(itypi,itypj)
1090             e2=fac*bb(itypi,itypj)
1091             evdwij=e1+e2
1092 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1093 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1094 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1095 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1096 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1097 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1098             evdw=evdw+evdwij
1099 C
1100 C Calculate the components of the gradient in DC and X
1101 C
1102             fac=-rrij*(e1+evdwij)
1103             gg(1)=xj*fac
1104             gg(2)=yj*fac
1105             gg(3)=zj*fac
1106             do k=1,3
1107               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1108               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1109               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1110               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1111             enddo
1112 cgrad            do k=i,j-1
1113 cgrad              do l=1,3
1114 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1115 cgrad              enddo
1116 cgrad            enddo
1117 C
1118 C 12/1/95, revised on 5/20/97
1119 C
1120 C Calculate the contact function. The ith column of the array JCONT will
1121 C contain the numbers of atoms that make contacts with the atom I (of numbers
1122 C greater than I). The arrays FACONT and GACONT will contain the values of
1123 C the contact function and its derivative.
1124 C
1125 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1126 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1127 C Uncomment next line, if the correlation interactions are contact function only
1128             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1129               rij=dsqrt(rij)
1130               sigij=sigma(itypi,itypj)
1131               r0ij=rs0(itypi,itypj)
1132 C
1133 C Check whether the SC's are not too far to make a contact.
1134 C
1135               rcut=1.5d0*r0ij
1136               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1137 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1138 C
1139               if (fcont.gt.0.0D0) then
1140 C If the SC-SC distance if close to sigma, apply spline.
1141 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1142 cAdam &             fcont1,fprimcont1)
1143 cAdam           fcont1=1.0d0-fcont1
1144 cAdam           if (fcont1.gt.0.0d0) then
1145 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1146 cAdam             fcont=fcont*fcont1
1147 cAdam           endif
1148 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1149 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1150 cga             do k=1,3
1151 cga               gg(k)=gg(k)*eps0ij
1152 cga             enddo
1153 cga             eps0ij=-evdwij*eps0ij
1154 C Uncomment for AL's type of SC correlation interactions.
1155 cadam           eps0ij=-evdwij
1156                 num_conti=num_conti+1
1157                 jcont(num_conti,i)=j
1158                 facont(num_conti,i)=fcont*eps0ij
1159                 fprimcont=eps0ij*fprimcont/rij
1160                 fcont=expon*fcont
1161 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1162 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1163 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1164 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1165                 gacont(1,num_conti,i)=-fprimcont*xj
1166                 gacont(2,num_conti,i)=-fprimcont*yj
1167                 gacont(3,num_conti,i)=-fprimcont*zj
1168 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1169 cd              write (iout,'(2i3,3f10.5)')
1170 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1171               endif
1172             endif
1173           enddo      ! j
1174         enddo        ! iint
1175 C Change 12/1/95
1176         num_cont(i)=num_conti
1177       enddo          ! i
1178       do i=1,nct
1179         do j=1,3
1180           gvdwc(j,i)=expon*gvdwc(j,i)
1181           gvdwx(j,i)=expon*gvdwx(j,i)
1182         enddo
1183       enddo
1184 C******************************************************************************
1185 C
1186 C                              N O T E !!!
1187 C
1188 C To save time, the factor of EXPON has been extracted from ALL components
1189 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1190 C use!
1191 C
1192 C******************************************************************************
1193       return
1194       end
1195 C-----------------------------------------------------------------------------
1196       subroutine eljk(evdw)
1197 C
1198 C This subroutine calculates the interaction energy of nonbonded side chains
1199 C assuming the LJK potential of interaction.
1200 C
1201       implicit real*8 (a-h,o-z)
1202       include 'DIMENSIONS'
1203       include 'COMMON.GEO'
1204       include 'COMMON.VAR'
1205       include 'COMMON.LOCAL'
1206       include 'COMMON.CHAIN'
1207       include 'COMMON.DERIV'
1208       include 'COMMON.INTERACT'
1209       include 'COMMON.IOUNITS'
1210       include 'COMMON.NAMES'
1211       dimension gg(3)
1212       logical scheck
1213 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1214       evdw=0.0D0
1215       do i=iatsc_s,iatsc_e
1216         itypi=iabs(itype(i))
1217         if (itypi.eq.ntyp1) cycle
1218         itypi1=iabs(itype(i+1))
1219         xi=c(1,nres+i)
1220         yi=c(2,nres+i)
1221         zi=c(3,nres+i)
1222 C
1223 C Calculate SC interaction energy.
1224 C
1225         do iint=1,nint_gr(i)
1226           do j=istart(i,iint),iend(i,iint)
1227             itypj=iabs(itype(j))
1228             if (itypj.eq.ntyp1) cycle
1229             xj=c(1,nres+j)-xi
1230             yj=c(2,nres+j)-yi
1231             zj=c(3,nres+j)-zi
1232             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1233             fac_augm=rrij**expon
1234             e_augm=augm(itypi,itypj)*fac_augm
1235             r_inv_ij=dsqrt(rrij)
1236             rij=1.0D0/r_inv_ij
1237             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1238             fac=r_shift_inv**expon
1239             e1=fac*fac*aa(itypi,itypj)
1240             e2=fac*bb(itypi,itypj)
1241             evdwij=e_augm+e1+e2
1242 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1243 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1244 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1245 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1246 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1247 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1248 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1249             evdw=evdw+evdwij
1250 C
1251 C Calculate the components of the gradient in DC and X
1252 C
1253             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1254             gg(1)=xj*fac
1255             gg(2)=yj*fac
1256             gg(3)=zj*fac
1257             do k=1,3
1258               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1259               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1260               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1261               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1262             enddo
1263 cgrad            do k=i,j-1
1264 cgrad              do l=1,3
1265 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1266 cgrad              enddo
1267 cgrad            enddo
1268           enddo      ! j
1269         enddo        ! iint
1270       enddo          ! i
1271       do i=1,nct
1272         do j=1,3
1273           gvdwc(j,i)=expon*gvdwc(j,i)
1274           gvdwx(j,i)=expon*gvdwx(j,i)
1275         enddo
1276       enddo
1277       return
1278       end
1279 C-----------------------------------------------------------------------------
1280       subroutine ebp(evdw)
1281 C
1282 C This subroutine calculates the interaction energy of nonbonded side chains
1283 C assuming the Berne-Pechukas potential of interaction.
1284 C
1285       implicit real*8 (a-h,o-z)
1286       include 'DIMENSIONS'
1287       include 'COMMON.GEO'
1288       include 'COMMON.VAR'
1289       include 'COMMON.LOCAL'
1290       include 'COMMON.CHAIN'
1291       include 'COMMON.DERIV'
1292       include 'COMMON.NAMES'
1293       include 'COMMON.INTERACT'
1294       include 'COMMON.IOUNITS'
1295       include 'COMMON.CALC'
1296       common /srutu/ icall
1297 c     double precision rrsave(maxdim)
1298       logical lprn
1299       evdw=0.0D0
1300 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1301       evdw=0.0D0
1302 c     if (icall.eq.0) then
1303 c       lprn=.true.
1304 c     else
1305         lprn=.false.
1306 c     endif
1307       ind=0
1308       do i=iatsc_s,iatsc_e
1309         itypi=iabs(itype(i))
1310         if (itypi.eq.ntyp1) cycle
1311         itypi1=iabs(itype(i+1))
1312         xi=c(1,nres+i)
1313         yi=c(2,nres+i)
1314         zi=c(3,nres+i)
1315         dxi=dc_norm(1,nres+i)
1316         dyi=dc_norm(2,nres+i)
1317         dzi=dc_norm(3,nres+i)
1318 c        dsci_inv=dsc_inv(itypi)
1319         dsci_inv=vbld_inv(i+nres)
1320 C
1321 C Calculate SC interaction energy.
1322 C
1323         do iint=1,nint_gr(i)
1324           do j=istart(i,iint),iend(i,iint)
1325             ind=ind+1
1326             itypj=iabs(itype(j))
1327             if (itypj.eq.ntyp1) cycle
1328 c            dscj_inv=dsc_inv(itypj)
1329             dscj_inv=vbld_inv(j+nres)
1330             chi1=chi(itypi,itypj)
1331             chi2=chi(itypj,itypi)
1332             chi12=chi1*chi2
1333             chip1=chip(itypi)
1334             chip2=chip(itypj)
1335             chip12=chip1*chip2
1336             alf1=alp(itypi)
1337             alf2=alp(itypj)
1338             alf12=0.5D0*(alf1+alf2)
1339 C For diagnostics only!!!
1340 c           chi1=0.0D0
1341 c           chi2=0.0D0
1342 c           chi12=0.0D0
1343 c           chip1=0.0D0
1344 c           chip2=0.0D0
1345 c           chip12=0.0D0
1346 c           alf1=0.0D0
1347 c           alf2=0.0D0
1348 c           alf12=0.0D0
1349             xj=c(1,nres+j)-xi
1350             yj=c(2,nres+j)-yi
1351             zj=c(3,nres+j)-zi
1352             dxj=dc_norm(1,nres+j)
1353             dyj=dc_norm(2,nres+j)
1354             dzj=dc_norm(3,nres+j)
1355             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1356 cd          if (icall.eq.0) then
1357 cd            rrsave(ind)=rrij
1358 cd          else
1359 cd            rrij=rrsave(ind)
1360 cd          endif
1361             rij=dsqrt(rrij)
1362 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1363             call sc_angular
1364 C Calculate whole angle-dependent part of epsilon and contributions
1365 C to its derivatives
1366             fac=(rrij*sigsq)**expon2
1367             e1=fac*fac*aa(itypi,itypj)
1368             e2=fac*bb(itypi,itypj)
1369             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1370             eps2der=evdwij*eps3rt
1371             eps3der=evdwij*eps2rt
1372             evdwij=evdwij*eps2rt*eps3rt
1373             evdw=evdw+evdwij
1374             if (lprn) then
1375             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1376             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1377 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1378 cd     &        restyp(itypi),i,restyp(itypj),j,
1379 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1380 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1381 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1382 cd     &        evdwij
1383             endif
1384 C Calculate gradient components.
1385             e1=e1*eps1*eps2rt**2*eps3rt**2
1386             fac=-expon*(e1+evdwij)
1387             sigder=fac/sigsq
1388             fac=rrij*fac
1389 C Calculate radial part of the gradient
1390             gg(1)=xj*fac
1391             gg(2)=yj*fac
1392             gg(3)=zj*fac
1393 C Calculate the angular part of the gradient and sum add the contributions
1394 C to the appropriate components of the Cartesian gradient.
1395             call sc_grad
1396           enddo      ! j
1397         enddo        ! iint
1398       enddo          ! i
1399 c     stop
1400       return
1401       end
1402 C-----------------------------------------------------------------------------
1403       subroutine egb(evdw)
1404 C
1405 C This subroutine calculates the interaction energy of nonbonded side chains
1406 C assuming the Gay-Berne potential of interaction.
1407 C
1408       implicit real*8 (a-h,o-z)
1409       include 'DIMENSIONS'
1410       include 'COMMON.GEO'
1411       include 'COMMON.VAR'
1412       include 'COMMON.LOCAL'
1413       include 'COMMON.CHAIN'
1414       include 'COMMON.DERIV'
1415       include 'COMMON.NAMES'
1416       include 'COMMON.INTERACT'
1417       include 'COMMON.IOUNITS'
1418       include 'COMMON.CALC'
1419       include 'COMMON.CONTROL'
1420       include 'COMMON.SBRIDGE'
1421       logical lprn
1422       evdw=0.0D0
1423 ccccc      energy_dec=.false.
1424 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1425       evdw=0.0D0
1426       lprn=.false.
1427 c     if (icall.eq.0) lprn=.false.
1428       ind=0
1429       do i=iatsc_s,iatsc_e
1430         itypi=iabs(itype(i))
1431         if (itypi.eq.ntyp1) cycle
1432         itypi1=iabs(itype(i+1))
1433         xi=c(1,nres+i)
1434         yi=c(2,nres+i)
1435         zi=c(3,nres+i)
1436         dxi=dc_norm(1,nres+i)
1437         dyi=dc_norm(2,nres+i)
1438         dzi=dc_norm(3,nres+i)
1439 c        dsci_inv=dsc_inv(itypi)
1440         dsci_inv=vbld_inv(i+nres)
1441 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1442 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1443 C
1444 C Calculate SC interaction energy.
1445 C
1446         do iint=1,nint_gr(i)
1447           do j=istart(i,iint),iend(i,iint)
1448             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1449               call dyn_ssbond_ene(i,j,evdwij)
1450               evdw=evdw+evdwij
1451               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1452      &                        'evdw',i,j,evdwij,' ss'
1453             ELSE
1454             ind=ind+1
1455             itypj=iabs(itype(j))
1456             if (itypj.eq.ntyp1) cycle
1457 c            dscj_inv=dsc_inv(itypj)
1458             dscj_inv=vbld_inv(j+nres)
1459 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1460 c     &       1.0d0/vbld(j+nres)
1461 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1462             sig0ij=sigma(itypi,itypj)
1463             chi1=chi(itypi,itypj)
1464             chi2=chi(itypj,itypi)
1465             chi12=chi1*chi2
1466             chip1=chip(itypi)
1467             chip2=chip(itypj)
1468             chip12=chip1*chip2
1469             alf1=alp(itypi)
1470             alf2=alp(itypj)
1471             alf12=0.5D0*(alf1+alf2)
1472 C For diagnostics only!!!
1473 c           chi1=0.0D0
1474 c           chi2=0.0D0
1475 c           chi12=0.0D0
1476 c           chip1=0.0D0
1477 c           chip2=0.0D0
1478 c           chip12=0.0D0
1479 c           alf1=0.0D0
1480 c           alf2=0.0D0
1481 c           alf12=0.0D0
1482             xj=c(1,nres+j)-xi
1483             yj=c(2,nres+j)-yi
1484             zj=c(3,nres+j)-zi
1485             dxj=dc_norm(1,nres+j)
1486             dyj=dc_norm(2,nres+j)
1487             dzj=dc_norm(3,nres+j)
1488 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1489 c            write (iout,*) "j",j," dc_norm",
1490 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1491             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1492             rij=dsqrt(rrij)
1493 C Calculate angle-dependent terms of energy and contributions to their
1494 C derivatives.
1495             call sc_angular
1496             sigsq=1.0D0/sigsq
1497             sig=sig0ij*dsqrt(sigsq)
1498             rij_shift=1.0D0/rij-sig+sig0ij
1499 c for diagnostics; uncomment
1500 c            rij_shift=1.2*sig0ij
1501 C I hate to put IF's in the loops, but here don't have another choice!!!!
1502             if (rij_shift.le.0.0D0) then
1503               evdw=1.0D20
1504 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1505 cd     &        restyp(itypi),i,restyp(itypj),j,
1506 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1507               return
1508             endif
1509             sigder=-sig*sigsq
1510 c---------------------------------------------------------------
1511             rij_shift=1.0D0/rij_shift
1512             fac=rij_shift**expon
1513             e1=fac*fac*aa(itypi,itypj)
1514             e2=fac*bb(itypi,itypj)
1515             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1516             eps2der=evdwij*eps3rt
1517             eps3der=evdwij*eps2rt
1518 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1519 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1520             evdwij=evdwij*eps2rt*eps3rt
1521             evdw=evdw+evdwij
1522             if (lprn) then
1523             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1524             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1525             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1526      &        restyp(itypi),i,restyp(itypj),j,
1527      &        epsi,sigm,chi1,chi2,chip1,chip2,
1528      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1529      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1530      &        evdwij
1531             endif
1532
1533             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1534      &                        'evdw',i,j,evdwij
1535
1536 C Calculate gradient components.
1537             e1=e1*eps1*eps2rt**2*eps3rt**2
1538             fac=-expon*(e1+evdwij)*rij_shift
1539             sigder=fac*sigder
1540             fac=rij*fac
1541 c            fac=0.0d0
1542 C Calculate the radial part of the gradient
1543             gg(1)=xj*fac
1544             gg(2)=yj*fac
1545             gg(3)=zj*fac
1546 C Calculate angular part of the gradient.
1547             call sc_grad
1548           endif      ! dyn_ss
1549           enddo      ! j
1550         enddo        ! iint
1551       enddo          ! i
1552 c      write (iout,*) "Number of loop steps in EGB:",ind
1553 cccc      energy_dec=.false.
1554       return
1555       end
1556 C-----------------------------------------------------------------------------
1557       subroutine egbv(evdw)
1558 C
1559 C This subroutine calculates the interaction energy of nonbonded side chains
1560 C assuming the Gay-Berne-Vorobjev potential of interaction.
1561 C
1562       implicit real*8 (a-h,o-z)
1563       include 'DIMENSIONS'
1564       include 'COMMON.GEO'
1565       include 'COMMON.VAR'
1566       include 'COMMON.LOCAL'
1567       include 'COMMON.CHAIN'
1568       include 'COMMON.DERIV'
1569       include 'COMMON.NAMES'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.IOUNITS'
1572       include 'COMMON.CALC'
1573       common /srutu/ icall
1574       logical lprn
1575       evdw=0.0D0
1576 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1577       evdw=0.0D0
1578       lprn=.false.
1579 c     if (icall.eq.0) lprn=.true.
1580       ind=0
1581       do i=iatsc_s,iatsc_e
1582         itypi=iabs(itype(i))
1583         if (itypi.eq.ntyp1) cycle
1584         itypi1=iabs(itype(i+1))
1585         xi=c(1,nres+i)
1586         yi=c(2,nres+i)
1587         zi=c(3,nres+i)
1588         dxi=dc_norm(1,nres+i)
1589         dyi=dc_norm(2,nres+i)
1590         dzi=dc_norm(3,nres+i)
1591 c        dsci_inv=dsc_inv(itypi)
1592         dsci_inv=vbld_inv(i+nres)
1593 C
1594 C Calculate SC interaction energy.
1595 C
1596         do iint=1,nint_gr(i)
1597           do j=istart(i,iint),iend(i,iint)
1598             ind=ind+1
1599             itypj=iabs(itype(j))
1600             if (itypj.eq.ntyp1) cycle
1601 c            dscj_inv=dsc_inv(itypj)
1602             dscj_inv=vbld_inv(j+nres)
1603             sig0ij=sigma(itypi,itypj)
1604             r0ij=r0(itypi,itypj)
1605             chi1=chi(itypi,itypj)
1606             chi2=chi(itypj,itypi)
1607             chi12=chi1*chi2
1608             chip1=chip(itypi)
1609             chip2=chip(itypj)
1610             chip12=chip1*chip2
1611             alf1=alp(itypi)
1612             alf2=alp(itypj)
1613             alf12=0.5D0*(alf1+alf2)
1614 C For diagnostics only!!!
1615 c           chi1=0.0D0
1616 c           chi2=0.0D0
1617 c           chi12=0.0D0
1618 c           chip1=0.0D0
1619 c           chip2=0.0D0
1620 c           chip12=0.0D0
1621 c           alf1=0.0D0
1622 c           alf2=0.0D0
1623 c           alf12=0.0D0
1624             xj=c(1,nres+j)-xi
1625             yj=c(2,nres+j)-yi
1626             zj=c(3,nres+j)-zi
1627             dxj=dc_norm(1,nres+j)
1628             dyj=dc_norm(2,nres+j)
1629             dzj=dc_norm(3,nres+j)
1630             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1631             rij=dsqrt(rrij)
1632 C Calculate angle-dependent terms of energy and contributions to their
1633 C derivatives.
1634             call sc_angular
1635             sigsq=1.0D0/sigsq
1636             sig=sig0ij*dsqrt(sigsq)
1637             rij_shift=1.0D0/rij-sig+r0ij
1638 C I hate to put IF's in the loops, but here don't have another choice!!!!
1639             if (rij_shift.le.0.0D0) then
1640               evdw=1.0D20
1641               return
1642             endif
1643             sigder=-sig*sigsq
1644 c---------------------------------------------------------------
1645             rij_shift=1.0D0/rij_shift
1646             fac=rij_shift**expon
1647             e1=fac*fac*aa(itypi,itypj)
1648             e2=fac*bb(itypi,itypj)
1649             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1650             eps2der=evdwij*eps3rt
1651             eps3der=evdwij*eps2rt
1652             fac_augm=rrij**expon
1653             e_augm=augm(itypi,itypj)*fac_augm
1654             evdwij=evdwij*eps2rt*eps3rt
1655             evdw=evdw+evdwij+e_augm
1656             if (lprn) then
1657             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1658             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1659             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1660      &        restyp(itypi),i,restyp(itypj),j,
1661      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1662      &        chi1,chi2,chip1,chip2,
1663      &        eps1,eps2rt**2,eps3rt**2,
1664      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1665      &        evdwij+e_augm
1666             endif
1667 C Calculate gradient components.
1668             e1=e1*eps1*eps2rt**2*eps3rt**2
1669             fac=-expon*(e1+evdwij)*rij_shift
1670             sigder=fac*sigder
1671             fac=rij*fac-2*expon*rrij*e_augm
1672 C Calculate the radial part of the gradient
1673             gg(1)=xj*fac
1674             gg(2)=yj*fac
1675             gg(3)=zj*fac
1676 C Calculate angular part of the gradient.
1677             call sc_grad
1678           enddo      ! j
1679         enddo        ! iint
1680       enddo          ! i
1681       end
1682 C-----------------------------------------------------------------------------
1683       subroutine sc_angular
1684 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1685 C om12. Called by ebp, egb, and egbv.
1686       implicit none
1687       include 'COMMON.CALC'
1688       include 'COMMON.IOUNITS'
1689       erij(1)=xj*rij
1690       erij(2)=yj*rij
1691       erij(3)=zj*rij
1692       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1693       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1694       om12=dxi*dxj+dyi*dyj+dzi*dzj
1695       chiom12=chi12*om12
1696 C Calculate eps1(om12) and its derivative in om12
1697       faceps1=1.0D0-om12*chiom12
1698       faceps1_inv=1.0D0/faceps1
1699       eps1=dsqrt(faceps1_inv)
1700 C Following variable is eps1*deps1/dom12
1701       eps1_om12=faceps1_inv*chiom12
1702 c diagnostics only
1703 c      faceps1_inv=om12
1704 c      eps1=om12
1705 c      eps1_om12=1.0d0
1706 c      write (iout,*) "om12",om12," eps1",eps1
1707 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1708 C and om12.
1709       om1om2=om1*om2
1710       chiom1=chi1*om1
1711       chiom2=chi2*om2
1712       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1713       sigsq=1.0D0-facsig*faceps1_inv
1714       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1715       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1716       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1717 c diagnostics only
1718 c      sigsq=1.0d0
1719 c      sigsq_om1=0.0d0
1720 c      sigsq_om2=0.0d0
1721 c      sigsq_om12=0.0d0
1722 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1723 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1724 c     &    " eps1",eps1
1725 C Calculate eps2 and its derivatives in om1, om2, and om12.
1726       chipom1=chip1*om1
1727       chipom2=chip2*om2
1728       chipom12=chip12*om12
1729       facp=1.0D0-om12*chipom12
1730       facp_inv=1.0D0/facp
1731       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1732 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1733 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1734 C Following variable is the square root of eps2
1735       eps2rt=1.0D0-facp1*facp_inv
1736 C Following three variables are the derivatives of the square root of eps
1737 C in om1, om2, and om12.
1738       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1739       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1740       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1741 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1742       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1743 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1744 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1745 c     &  " eps2rt_om12",eps2rt_om12
1746 C Calculate whole angle-dependent part of epsilon and contributions
1747 C to its derivatives
1748       return
1749       end
1750 C----------------------------------------------------------------------------
1751       subroutine sc_grad
1752       implicit real*8 (a-h,o-z)
1753       include 'DIMENSIONS'
1754       include 'COMMON.CHAIN'
1755       include 'COMMON.DERIV'
1756       include 'COMMON.CALC'
1757       include 'COMMON.IOUNITS'
1758       double precision dcosom1(3),dcosom2(3)
1759       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1760       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1761       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1762      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1763 c diagnostics only
1764 c      eom1=0.0d0
1765 c      eom2=0.0d0
1766 c      eom12=evdwij*eps1_om12
1767 c end diagnostics
1768 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1769 c     &  " sigder",sigder
1770 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1771 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1772       do k=1,3
1773         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1774         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1775       enddo
1776       do k=1,3
1777         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1778       enddo
1779 c      write (iout,*) "gg",(gg(k),k=1,3)
1780       do k=1,3
1781         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1782      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1783      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1784         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1785      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1786      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1787 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1788 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1789 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1790 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1791       enddo
1792 C
1793 C Calculate the components of the gradient in DC and X
1794 C
1795 cgrad      do k=i,j-1
1796 cgrad        do l=1,3
1797 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1798 cgrad        enddo
1799 cgrad      enddo
1800       do l=1,3
1801         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1802         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1803       enddo
1804       return
1805       end
1806 C-----------------------------------------------------------------------
1807       subroutine e_softsphere(evdw)
1808 C
1809 C This subroutine calculates the interaction energy of nonbonded side chains
1810 C assuming the LJ potential of interaction.
1811 C
1812       implicit real*8 (a-h,o-z)
1813       include 'DIMENSIONS'
1814       parameter (accur=1.0d-10)
1815       include 'COMMON.GEO'
1816       include 'COMMON.VAR'
1817       include 'COMMON.LOCAL'
1818       include 'COMMON.CHAIN'
1819       include 'COMMON.DERIV'
1820       include 'COMMON.INTERACT'
1821       include 'COMMON.TORSION'
1822       include 'COMMON.SBRIDGE'
1823       include 'COMMON.NAMES'
1824       include 'COMMON.IOUNITS'
1825       include 'COMMON.CONTACTS'
1826       dimension gg(3)
1827 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1828       evdw=0.0D0
1829       do i=iatsc_s,iatsc_e
1830         itypi=iabs(itype(i))
1831         if (itypi.eq.ntyp1) cycle
1832         itypi1=iabs(itype(i+1))
1833         xi=c(1,nres+i)
1834         yi=c(2,nres+i)
1835         zi=c(3,nres+i)
1836 C
1837 C Calculate SC interaction energy.
1838 C
1839         do iint=1,nint_gr(i)
1840 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1841 cd   &                  'iend=',iend(i,iint)
1842           do j=istart(i,iint),iend(i,iint)
1843             itypj=iabs(itype(j))
1844             if (itypj.eq.ntyp1) cycle
1845             xj=c(1,nres+j)-xi
1846             yj=c(2,nres+j)-yi
1847             zj=c(3,nres+j)-zi
1848             rij=xj*xj+yj*yj+zj*zj
1849 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1850             r0ij=r0(itypi,itypj)
1851             r0ijsq=r0ij*r0ij
1852 c            print *,i,j,r0ij,dsqrt(rij)
1853             if (rij.lt.r0ijsq) then
1854               evdwij=0.25d0*(rij-r0ijsq)**2
1855               fac=rij-r0ijsq
1856             else
1857               evdwij=0.0d0
1858               fac=0.0d0
1859             endif
1860             evdw=evdw+evdwij
1861 C
1862 C Calculate the components of the gradient in DC and X
1863 C
1864             gg(1)=xj*fac
1865             gg(2)=yj*fac
1866             gg(3)=zj*fac
1867             do k=1,3
1868               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1869               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1870               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1871               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1872             enddo
1873 cgrad            do k=i,j-1
1874 cgrad              do l=1,3
1875 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1876 cgrad              enddo
1877 cgrad            enddo
1878           enddo ! j
1879         enddo ! iint
1880       enddo ! i
1881       return
1882       end
1883 C--------------------------------------------------------------------------
1884       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1885      &              eello_turn4)
1886 C
1887 C Soft-sphere potential of p-p interaction
1888 C
1889       implicit real*8 (a-h,o-z)
1890       include 'DIMENSIONS'
1891       include 'COMMON.CONTROL'
1892       include 'COMMON.IOUNITS'
1893       include 'COMMON.GEO'
1894       include 'COMMON.VAR'
1895       include 'COMMON.LOCAL'
1896       include 'COMMON.CHAIN'
1897       include 'COMMON.DERIV'
1898       include 'COMMON.INTERACT'
1899       include 'COMMON.CONTACTS'
1900       include 'COMMON.TORSION'
1901       include 'COMMON.VECTORS'
1902       include 'COMMON.FFIELD'
1903       dimension ggg(3)
1904 cd      write(iout,*) 'In EELEC_soft_sphere'
1905       ees=0.0D0
1906       evdw1=0.0D0
1907       eel_loc=0.0d0
1908       eello_turn3=0.0d0
1909       eello_turn4=0.0d0
1910       ind=0
1911       do i=iatel_s,iatel_e
1912         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1913         dxi=dc(1,i)
1914         dyi=dc(2,i)
1915         dzi=dc(3,i)
1916         xmedi=c(1,i)+0.5d0*dxi
1917         ymedi=c(2,i)+0.5d0*dyi
1918         zmedi=c(3,i)+0.5d0*dzi
1919         num_conti=0
1920 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1921         do j=ielstart(i),ielend(i)
1922           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1923           ind=ind+1
1924           iteli=itel(i)
1925           itelj=itel(j)
1926           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1927           r0ij=rpp(iteli,itelj)
1928           r0ijsq=r0ij*r0ij
1929           dxj=dc(1,j)
1930           dyj=dc(2,j)
1931           dzj=dc(3,j)
1932           xj=c(1,j)+0.5D0*dxj-xmedi
1933           yj=c(2,j)+0.5D0*dyj-ymedi
1934           zj=c(3,j)+0.5D0*dzj-zmedi
1935           rij=xj*xj+yj*yj+zj*zj
1936           if (rij.lt.r0ijsq) then
1937             evdw1ij=0.25d0*(rij-r0ijsq)**2
1938             fac=rij-r0ijsq
1939           else
1940             evdw1ij=0.0d0
1941             fac=0.0d0
1942           endif
1943           evdw1=evdw1+evdw1ij
1944 C
1945 C Calculate contributions to the Cartesian gradient.
1946 C
1947           ggg(1)=fac*xj
1948           ggg(2)=fac*yj
1949           ggg(3)=fac*zj
1950           do k=1,3
1951             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1952             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1953           enddo
1954 *
1955 * Loop over residues i+1 thru j-1.
1956 *
1957 cgrad          do k=i+1,j-1
1958 cgrad            do l=1,3
1959 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1960 cgrad            enddo
1961 cgrad          enddo
1962         enddo ! j
1963       enddo   ! i
1964 cgrad      do i=nnt,nct-1
1965 cgrad        do k=1,3
1966 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1967 cgrad        enddo
1968 cgrad        do j=i+1,nct-1
1969 cgrad          do k=1,3
1970 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1971 cgrad          enddo
1972 cgrad        enddo
1973 cgrad      enddo
1974       return
1975       end
1976 c------------------------------------------------------------------------------
1977       subroutine vec_and_deriv
1978       implicit real*8 (a-h,o-z)
1979       include 'DIMENSIONS'
1980 #ifdef MPI
1981       include 'mpif.h'
1982 #endif
1983       include 'COMMON.IOUNITS'
1984       include 'COMMON.GEO'
1985       include 'COMMON.VAR'
1986       include 'COMMON.LOCAL'
1987       include 'COMMON.CHAIN'
1988       include 'COMMON.VECTORS'
1989       include 'COMMON.SETUP'
1990       include 'COMMON.TIME1'
1991       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1992 C Compute the local reference systems. For reference system (i), the
1993 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1994 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1995 #ifdef PARVEC
1996       do i=ivec_start,ivec_end
1997 #else
1998       do i=1,nres-1
1999 #endif
2000           if (i.eq.nres-1) then
2001 C Case of the last full residue
2002 C Compute the Z-axis
2003             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2004             costh=dcos(pi-theta(nres))
2005             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2006             do k=1,3
2007               uz(k,i)=fac*uz(k,i)
2008             enddo
2009 C Compute the derivatives of uz
2010             uzder(1,1,1)= 0.0d0
2011             uzder(2,1,1)=-dc_norm(3,i-1)
2012             uzder(3,1,1)= dc_norm(2,i-1)
2013             uzder(1,2,1)= dc_norm(3,i-1)
2014             uzder(2,2,1)= 0.0d0
2015             uzder(3,2,1)=-dc_norm(1,i-1)
2016             uzder(1,3,1)=-dc_norm(2,i-1)
2017             uzder(2,3,1)= dc_norm(1,i-1)
2018             uzder(3,3,1)= 0.0d0
2019             uzder(1,1,2)= 0.0d0
2020             uzder(2,1,2)= dc_norm(3,i)
2021             uzder(3,1,2)=-dc_norm(2,i)
2022             uzder(1,2,2)=-dc_norm(3,i)
2023             uzder(2,2,2)= 0.0d0
2024             uzder(3,2,2)= dc_norm(1,i)
2025             uzder(1,3,2)= dc_norm(2,i)
2026             uzder(2,3,2)=-dc_norm(1,i)
2027             uzder(3,3,2)= 0.0d0
2028 C Compute the Y-axis
2029             facy=fac
2030             do k=1,3
2031               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2032             enddo
2033 C Compute the derivatives of uy
2034             do j=1,3
2035               do k=1,3
2036                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2037      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2038                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2039               enddo
2040               uyder(j,j,1)=uyder(j,j,1)-costh
2041               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2042             enddo
2043             do j=1,2
2044               do k=1,3
2045                 do l=1,3
2046                   uygrad(l,k,j,i)=uyder(l,k,j)
2047                   uzgrad(l,k,j,i)=uzder(l,k,j)
2048                 enddo
2049               enddo
2050             enddo
2051             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2052             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2053             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2054             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2055           else
2056 C Other residues
2057 C Compute the Z-axis
2058             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2059             costh=dcos(pi-theta(i+2))
2060             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2061             do k=1,3
2062               uz(k,i)=fac*uz(k,i)
2063             enddo
2064 C Compute the derivatives of uz
2065             uzder(1,1,1)= 0.0d0
2066             uzder(2,1,1)=-dc_norm(3,i+1)
2067             uzder(3,1,1)= dc_norm(2,i+1)
2068             uzder(1,2,1)= dc_norm(3,i+1)
2069             uzder(2,2,1)= 0.0d0
2070             uzder(3,2,1)=-dc_norm(1,i+1)
2071             uzder(1,3,1)=-dc_norm(2,i+1)
2072             uzder(2,3,1)= dc_norm(1,i+1)
2073             uzder(3,3,1)= 0.0d0
2074             uzder(1,1,2)= 0.0d0
2075             uzder(2,1,2)= dc_norm(3,i)
2076             uzder(3,1,2)=-dc_norm(2,i)
2077             uzder(1,2,2)=-dc_norm(3,i)
2078             uzder(2,2,2)= 0.0d0
2079             uzder(3,2,2)= dc_norm(1,i)
2080             uzder(1,3,2)= dc_norm(2,i)
2081             uzder(2,3,2)=-dc_norm(1,i)
2082             uzder(3,3,2)= 0.0d0
2083 C Compute the Y-axis
2084             facy=fac
2085             do k=1,3
2086               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2087             enddo
2088 C Compute the derivatives of uy
2089             do j=1,3
2090               do k=1,3
2091                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2092      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2093                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2094               enddo
2095               uyder(j,j,1)=uyder(j,j,1)-costh
2096               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2097             enddo
2098             do j=1,2
2099               do k=1,3
2100                 do l=1,3
2101                   uygrad(l,k,j,i)=uyder(l,k,j)
2102                   uzgrad(l,k,j,i)=uzder(l,k,j)
2103                 enddo
2104               enddo
2105             enddo
2106             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2107             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2108             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2109             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2110           endif
2111       enddo
2112       do i=1,nres-1
2113         vbld_inv_temp(1)=vbld_inv(i+1)
2114         if (i.lt.nres-1) then
2115           vbld_inv_temp(2)=vbld_inv(i+2)
2116           else
2117           vbld_inv_temp(2)=vbld_inv(i)
2118           endif
2119         do j=1,2
2120           do k=1,3
2121             do l=1,3
2122               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2123               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2124             enddo
2125           enddo
2126         enddo
2127       enddo
2128 #if defined(PARVEC) && defined(MPI)
2129       if (nfgtasks1.gt.1) then
2130         time00=MPI_Wtime()
2131 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2132 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2133 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2134         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2135      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2136      &   FG_COMM1,IERR)
2137         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2138      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2139      &   FG_COMM1,IERR)
2140         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2141      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2142      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2143         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2144      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2145      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2146         time_gather=time_gather+MPI_Wtime()-time00
2147       endif
2148 c      if (fg_rank.eq.0) then
2149 c        write (iout,*) "Arrays UY and UZ"
2150 c        do i=1,nres-1
2151 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2152 c     &     (uz(k,i),k=1,3)
2153 c        enddo
2154 c      endif
2155 #endif
2156       return
2157       end
2158 C-----------------------------------------------------------------------------
2159       subroutine check_vecgrad
2160       implicit real*8 (a-h,o-z)
2161       include 'DIMENSIONS'
2162       include 'COMMON.IOUNITS'
2163       include 'COMMON.GEO'
2164       include 'COMMON.VAR'
2165       include 'COMMON.LOCAL'
2166       include 'COMMON.CHAIN'
2167       include 'COMMON.VECTORS'
2168       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2169       dimension uyt(3,maxres),uzt(3,maxres)
2170       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2171       double precision delta /1.0d-7/
2172       call vec_and_deriv
2173 cd      do i=1,nres
2174 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2175 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2176 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2177 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2178 cd     &     (dc_norm(if90,i),if90=1,3)
2179 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2180 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2181 cd          write(iout,'(a)')
2182 cd      enddo
2183       do i=1,nres
2184         do j=1,2
2185           do k=1,3
2186             do l=1,3
2187               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2188               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2189             enddo
2190           enddo
2191         enddo
2192       enddo
2193       call vec_and_deriv
2194       do i=1,nres
2195         do j=1,3
2196           uyt(j,i)=uy(j,i)
2197           uzt(j,i)=uz(j,i)
2198         enddo
2199       enddo
2200       do i=1,nres
2201 cd        write (iout,*) 'i=',i
2202         do k=1,3
2203           erij(k)=dc_norm(k,i)
2204         enddo
2205         do j=1,3
2206           do k=1,3
2207             dc_norm(k,i)=erij(k)
2208           enddo
2209           dc_norm(j,i)=dc_norm(j,i)+delta
2210 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2211 c          do k=1,3
2212 c            dc_norm(k,i)=dc_norm(k,i)/fac
2213 c          enddo
2214 c          write (iout,*) (dc_norm(k,i),k=1,3)
2215 c          write (iout,*) (erij(k),k=1,3)
2216           call vec_and_deriv
2217           do k=1,3
2218             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2219             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2220             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2221             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2222           enddo
2223 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2224 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2225 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2226         enddo
2227         do k=1,3
2228           dc_norm(k,i)=erij(k)
2229         enddo
2230 cd        do k=1,3
2231 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2232 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2233 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2234 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2235 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2236 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2237 cd          write (iout,'(a)')
2238 cd        enddo
2239       enddo
2240       return
2241       end
2242 C--------------------------------------------------------------------------
2243       subroutine set_matrices
2244       implicit real*8 (a-h,o-z)
2245       include 'DIMENSIONS'
2246 #ifdef MPI
2247       include "mpif.h"
2248       include "COMMON.SETUP"
2249       integer IERR
2250       integer status(MPI_STATUS_SIZE)
2251 #endif
2252       include 'COMMON.IOUNITS'
2253       include 'COMMON.GEO'
2254       include 'COMMON.VAR'
2255       include 'COMMON.LOCAL'
2256       include 'COMMON.CHAIN'
2257       include 'COMMON.DERIV'
2258       include 'COMMON.INTERACT'
2259       include 'COMMON.CONTACTS'
2260       include 'COMMON.TORSION'
2261       include 'COMMON.VECTORS'
2262       include 'COMMON.FFIELD'
2263       double precision auxvec(2),auxmat(2,2)
2264 C
2265 C Compute the virtual-bond-torsional-angle dependent quantities needed
2266 C to calculate the el-loc multibody terms of various order.
2267 C
2268 c      write(iout,*) 'nphi=',nphi,nres
2269 #ifdef PARMAT
2270       do i=ivec_start+2,ivec_end+2
2271 #else
2272       do i=3,nres+1
2273 #endif
2274 #ifdef NEWCORR
2275         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2276           iti = itortyp(itype(i-2))
2277         else
2278           iti=ntortyp+1
2279         endif
2280 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2281         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2282           iti1 = itortyp(itype(i-1))
2283         else
2284           iti1=ntortyp+1
2285         endif
2286 c        write(iout,*),i
2287         b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0)
2288      &           +bnew1(2,1,iti)*sin(theta(i-1))
2289      &           +bnew1(3,1,iti)*cos(theta(i-1)/2.0)
2290         gtb1(1,i-2)=bnew1(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2291      &             +bnew1(2,1,iti)*cos(theta(i-1))
2292      &             -bnew1(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2293 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2294 c     &*(cos(theta(i)/2.0)
2295         b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0)
2296      &           +bnew2(2,1,iti)*sin(theta(i-1))
2297      &           +bnew2(3,1,iti)*cos(theta(i-1)/2.0)
2298 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2299 c     &*(cos(theta(i)/2.0)
2300         gtb2(1,i-2)=bnew2(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2301      &             +bnew2(2,1,iti)*cos(theta(i-1))
2302      &             -bnew2(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2303 c        if (ggb1(1,i).eq.0.0d0) then
2304 c        write(iout,*) 'i=',i,ggb1(1,i),
2305 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2306 c     &bnew1(2,1,iti)*cos(theta(i)),
2307 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2308 c        endif
2309         b1(2,i-2)=bnew1(1,2,iti)
2310         gtb1(2,i-2)=0.0
2311         b2(2,i-2)=bnew2(1,2,iti)
2312         gtb2(2,i-2)=0.0
2313         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2314         EE(1,2,i-2)=eeold(1,2,iti)
2315         EE(2,1,i-2)=eeold(2,1,iti)
2316         EE(2,2,i-2)=eeold(2,2,iti)
2317         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2318         gtEE(1,2,i-2)=0.0d0
2319         gtEE(2,2,i-2)=0.0d0
2320         gtEE(2,1,i-2)=0.0d0
2321 c        EE(2,2,iti)=0.0d0
2322 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2323 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2324 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2325 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2326        b1tilde(1,i-2)=b1(1,i-2)
2327        b1tilde(2,i-2)=-b1(2,i-2)
2328        b2tilde(1,i-2)=b2(1,i-2)
2329        b2tilde(2,i-2)=-b2(2,i-2)
2330 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2331 c       write (iout,*) 'theta=', theta(i-1)
2332        enddo
2333 #ifdef PARMAT
2334       do i=ivec_start+2,ivec_end+2
2335 #else
2336       do i=3,nres+1
2337 #endif
2338 #endif
2339         if (i .lt. nres+1) then
2340           sin1=dsin(phi(i))
2341           cos1=dcos(phi(i))
2342           sintab(i-2)=sin1
2343           costab(i-2)=cos1
2344           obrot(1,i-2)=cos1
2345           obrot(2,i-2)=sin1
2346           sin2=dsin(2*phi(i))
2347           cos2=dcos(2*phi(i))
2348           sintab2(i-2)=sin2
2349           costab2(i-2)=cos2
2350           obrot2(1,i-2)=cos2
2351           obrot2(2,i-2)=sin2
2352           Ug(1,1,i-2)=-cos1
2353           Ug(1,2,i-2)=-sin1
2354           Ug(2,1,i-2)=-sin1
2355           Ug(2,2,i-2)= cos1
2356           Ug2(1,1,i-2)=-cos2
2357           Ug2(1,2,i-2)=-sin2
2358           Ug2(2,1,i-2)=-sin2
2359           Ug2(2,2,i-2)= cos2
2360         else
2361           costab(i-2)=1.0d0
2362           sintab(i-2)=0.0d0
2363           obrot(1,i-2)=1.0d0
2364           obrot(2,i-2)=0.0d0
2365           obrot2(1,i-2)=0.0d0
2366           obrot2(2,i-2)=0.0d0
2367           Ug(1,1,i-2)=1.0d0
2368           Ug(1,2,i-2)=0.0d0
2369           Ug(2,1,i-2)=0.0d0
2370           Ug(2,2,i-2)=1.0d0
2371           Ug2(1,1,i-2)=0.0d0
2372           Ug2(1,2,i-2)=0.0d0
2373           Ug2(2,1,i-2)=0.0d0
2374           Ug2(2,2,i-2)=0.0d0
2375         endif
2376         if (i .gt. 3 .and. i .lt. nres+1) then
2377           obrot_der(1,i-2)=-sin1
2378           obrot_der(2,i-2)= cos1
2379           Ugder(1,1,i-2)= sin1
2380           Ugder(1,2,i-2)=-cos1
2381           Ugder(2,1,i-2)=-cos1
2382           Ugder(2,2,i-2)=-sin1
2383           dwacos2=cos2+cos2
2384           dwasin2=sin2+sin2
2385           obrot2_der(1,i-2)=-dwasin2
2386           obrot2_der(2,i-2)= dwacos2
2387           Ug2der(1,1,i-2)= dwasin2
2388           Ug2der(1,2,i-2)=-dwacos2
2389           Ug2der(2,1,i-2)=-dwacos2
2390           Ug2der(2,2,i-2)=-dwasin2
2391         else
2392           obrot_der(1,i-2)=0.0d0
2393           obrot_der(2,i-2)=0.0d0
2394           Ugder(1,1,i-2)=0.0d0
2395           Ugder(1,2,i-2)=0.0d0
2396           Ugder(2,1,i-2)=0.0d0
2397           Ugder(2,2,i-2)=0.0d0
2398           obrot2_der(1,i-2)=0.0d0
2399           obrot2_der(2,i-2)=0.0d0
2400           Ug2der(1,1,i-2)=0.0d0
2401           Ug2der(1,2,i-2)=0.0d0
2402           Ug2der(2,1,i-2)=0.0d0
2403           Ug2der(2,2,i-2)=0.0d0
2404         endif
2405 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2406         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2407           iti = itortyp(itype(i-2))
2408         else
2409           iti=ntortyp+1
2410         endif
2411 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2412         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2413           iti1 = itortyp(itype(i-1))
2414         else
2415           iti1=ntortyp+1
2416         endif
2417 cd        write (iout,*) '*******i',i,' iti1',iti
2418 cd        write (iout,*) 'b1',b1(:,iti)
2419 cd        write (iout,*) 'b2',b2(:,iti)
2420 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2421 c        if (i .gt. iatel_s+2) then
2422         if (i .gt. nnt+2) then
2423           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2424 #ifdef NEWCORR
2425           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2426 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2427 #endif
2428 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2429 c     &    EE(1,2,iti),EE(2,2,iti)
2430           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2431           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2432 c          write(iout,*) "Macierz EUG",
2433 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2434 c     &    eug(2,2,i-2)
2435           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2436      &    then
2437           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2438           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2439           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2440           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2441           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2442           endif
2443         else
2444           do k=1,2
2445             Ub2(k,i-2)=0.0d0
2446             Ctobr(k,i-2)=0.0d0
2447             Dtobr2(k,i-2)=0.0d0
2448             do l=1,2
2449               EUg(l,k,i-2)=0.0d0
2450               CUg(l,k,i-2)=0.0d0
2451               DUg(l,k,i-2)=0.0d0
2452               DtUg2(l,k,i-2)=0.0d0
2453             enddo
2454           enddo
2455         endif
2456         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2457         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2458         do k=1,2
2459           muder(k,i-2)=Ub2der(k,i-2)
2460         enddo
2461 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2462         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2463           if (itype(i-1).le.ntyp) then
2464             iti1 = itortyp(itype(i-1))
2465           else
2466             iti1=ntortyp+1
2467           endif
2468         else
2469           iti1=ntortyp+1
2470         endif
2471         do k=1,2
2472           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2473         enddo
2474 #ifdef MUOUT
2475         write (iout,'(2hmu,i3,3f8.1,7f10.5)') i-2,rad2deg*theta(i-1),
2476      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2477      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2478      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2479      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2)
2480 #endif
2481 cd        write (iout,*) 'mu ',mu(:,i-2)
2482 cd        write (iout,*) 'mu1',mu1(:,i-2)
2483 cd        write (iout,*) 'mu2',mu2(:,i-2)
2484         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2485      &  then
2486         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2487         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2488         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2489         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2490         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2491 C Vectors and matrices dependent on a single virtual-bond dihedral.
2492         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2493         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2494         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2495         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2496         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2497         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2498         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2499         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2500         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2501         endif
2502       enddo
2503 C Matrices dependent on two consecutive virtual-bond dihedrals.
2504 C The order of matrices is from left to right.
2505       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2506      &then
2507 c      do i=max0(ivec_start,2),ivec_end
2508       do i=2,nres-1
2509         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2510         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2511         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2512         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2513         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2514         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2515         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2516         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2517       enddo
2518       endif
2519 #if defined(MPI) && defined(PARMAT)
2520 #ifdef DEBUG
2521 c      if (fg_rank.eq.0) then
2522         write (iout,*) "Arrays UG and UGDER before GATHER"
2523         do i=1,nres-1
2524           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2525      &     ((ug(l,k,i),l=1,2),k=1,2),
2526      &     ((ugder(l,k,i),l=1,2),k=1,2)
2527         enddo
2528         write (iout,*) "Arrays UG2 and UG2DER"
2529         do i=1,nres-1
2530           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2531      &     ((ug2(l,k,i),l=1,2),k=1,2),
2532      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2533         enddo
2534         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2535         do i=1,nres-1
2536           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2537      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2538      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2539         enddo
2540         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2541         do i=1,nres-1
2542           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2543      &     costab(i),sintab(i),costab2(i),sintab2(i)
2544         enddo
2545         write (iout,*) "Array MUDER"
2546         do i=1,nres-1
2547           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2548         enddo
2549 c      endif
2550 #endif
2551       if (nfgtasks.gt.1) then
2552         time00=MPI_Wtime()
2553 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2554 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2555 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2556 #ifdef MATGATHER
2557         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2558      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2559      &   FG_COMM1,IERR)
2560         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2561      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2562      &   FG_COMM1,IERR)
2563         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2564      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2567      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2568      &   FG_COMM1,IERR)
2569         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2570      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2571      &   FG_COMM1,IERR)
2572         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2573      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2574      &   FG_COMM1,IERR)
2575         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2576      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2577      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2578         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2579      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2580      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2581         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2582      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2583      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2584         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2585      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2586      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2587         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2588      &  then
2589         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2593      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2594      &   FG_COMM1,IERR)
2595         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2596      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2597      &   FG_COMM1,IERR)
2598        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2599      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2600      &   FG_COMM1,IERR)
2601         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2602      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2603      &   FG_COMM1,IERR)
2604         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2605      &   ivec_count(fg_rank1),
2606      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2607      &   FG_COMM1,IERR)
2608         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2609      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2610      &   FG_COMM1,IERR)
2611         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2612      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2613      &   FG_COMM1,IERR)
2614         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2615      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2616      &   FG_COMM1,IERR)
2617         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2618      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2619      &   FG_COMM1,IERR)
2620         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2621      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2622      &   FG_COMM1,IERR)
2623         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2624      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2625      &   FG_COMM1,IERR)
2626         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2627      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2628      &   FG_COMM1,IERR)
2629         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2630      &   ivec_count(fg_rank1),
2631      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2632      &   FG_COMM1,IERR)
2633         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2634      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2635      &   FG_COMM1,IERR)
2636        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2637      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2638      &   FG_COMM1,IERR)
2639         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2640      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2641      &   FG_COMM1,IERR)
2642        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2643      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2644      &   FG_COMM1,IERR)
2645         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2646      &   ivec_count(fg_rank1),
2647      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2650      &   ivec_count(fg_rank1),
2651      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2652      &   FG_COMM1,IERR)
2653         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2654      &   ivec_count(fg_rank1),
2655      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2656      &   MPI_MAT2,FG_COMM1,IERR)
2657         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2658      &   ivec_count(fg_rank1),
2659      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2660      &   MPI_MAT2,FG_COMM1,IERR)
2661         endif
2662 #else
2663 c Passes matrix info through the ring
2664       isend=fg_rank1
2665       irecv=fg_rank1-1
2666       if (irecv.lt.0) irecv=nfgtasks1-1
2667       iprev=irecv
2668       inext=fg_rank1+1
2669       if (inext.ge.nfgtasks1) inext=0
2670       do i=1,nfgtasks1-1
2671 c        write (iout,*) "isend",isend," irecv",irecv
2672 c        call flush(iout)
2673         lensend=lentyp(isend)
2674         lenrecv=lentyp(irecv)
2675 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2676 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2677 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2678 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2679 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2680 c        write (iout,*) "Gather ROTAT1"
2681 c        call flush(iout)
2682 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2683 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2684 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2685 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2686 c        write (iout,*) "Gather ROTAT2"
2687 c        call flush(iout)
2688         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2689      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2690      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2691      &   iprev,4400+irecv,FG_COMM,status,IERR)
2692 c        write (iout,*) "Gather ROTAT_OLD"
2693 c        call flush(iout)
2694         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2695      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2696      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2697      &   iprev,5500+irecv,FG_COMM,status,IERR)
2698 c        write (iout,*) "Gather PRECOMP11"
2699 c        call flush(iout)
2700         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2701      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2702      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2703      &   iprev,6600+irecv,FG_COMM,status,IERR)
2704 c        write (iout,*) "Gather PRECOMP12"
2705 c        call flush(iout)
2706         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2707      &  then
2708         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2709      &   MPI_ROTAT2(lensend),inext,7700+isend,
2710      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2711      &   iprev,7700+irecv,FG_COMM,status,IERR)
2712 c        write (iout,*) "Gather PRECOMP21"
2713 c        call flush(iout)
2714         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2715      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2716      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2717      &   iprev,8800+irecv,FG_COMM,status,IERR)
2718 c        write (iout,*) "Gather PRECOMP22"
2719 c        call flush(iout)
2720         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2721      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2722      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2723      &   MPI_PRECOMP23(lenrecv),
2724      &   iprev,9900+irecv,FG_COMM,status,IERR)
2725 c        write (iout,*) "Gather PRECOMP23"
2726 c        call flush(iout)
2727         endif
2728         isend=irecv
2729         irecv=irecv-1
2730         if (irecv.lt.0) irecv=nfgtasks1-1
2731       enddo
2732 #endif
2733         time_gather=time_gather+MPI_Wtime()-time00
2734       endif
2735 #ifdef DEBUG
2736 c      if (fg_rank.eq.0) then
2737         write (iout,*) "Arrays UG and UGDER"
2738         do i=1,nres-1
2739           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2740      &     ((ug(l,k,i),l=1,2),k=1,2),
2741      &     ((ugder(l,k,i),l=1,2),k=1,2)
2742         enddo
2743         write (iout,*) "Arrays UG2 and UG2DER"
2744         do i=1,nres-1
2745           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2746      &     ((ug2(l,k,i),l=1,2),k=1,2),
2747      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2748         enddo
2749         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2750         do i=1,nres-1
2751           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2752      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2753      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2754         enddo
2755         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2756         do i=1,nres-1
2757           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2758      &     costab(i),sintab(i),costab2(i),sintab2(i)
2759         enddo
2760         write (iout,*) "Array MUDER"
2761         do i=1,nres-1
2762           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2763         enddo
2764 c      endif
2765 #endif
2766 #endif
2767 cd      do i=1,nres
2768 cd        iti = itortyp(itype(i))
2769 cd        write (iout,*) i
2770 cd        do j=1,2
2771 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2772 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2773 cd        enddo
2774 cd      enddo
2775       return
2776       end
2777 C--------------------------------------------------------------------------
2778       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2779 C
2780 C This subroutine calculates the average interaction energy and its gradient
2781 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2782 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2783 C The potential depends both on the distance of peptide-group centers and on
2784 C the orientation of the CA-CA virtual bonds.
2785 C
2786       implicit real*8 (a-h,o-z)
2787 #ifdef MPI
2788       include 'mpif.h'
2789 #endif
2790       include 'DIMENSIONS'
2791       include 'COMMON.CONTROL'
2792       include 'COMMON.SETUP'
2793       include 'COMMON.IOUNITS'
2794       include 'COMMON.GEO'
2795       include 'COMMON.VAR'
2796       include 'COMMON.LOCAL'
2797       include 'COMMON.CHAIN'
2798       include 'COMMON.DERIV'
2799       include 'COMMON.INTERACT'
2800       include 'COMMON.CONTACTS'
2801       include 'COMMON.TORSION'
2802       include 'COMMON.VECTORS'
2803       include 'COMMON.FFIELD'
2804       include 'COMMON.TIME1'
2805       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2806      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2807       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2808      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2809       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2810      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2811      &    num_conti,j1,j2
2812 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2813 #ifdef MOMENT
2814       double precision scal_el /1.0d0/
2815 #else
2816       double precision scal_el /0.5d0/
2817 #endif
2818 C 12/13/98
2819 C 13-go grudnia roku pamietnego...
2820       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2821      &                   0.0d0,1.0d0,0.0d0,
2822      &                   0.0d0,0.0d0,1.0d0/
2823 cd      write(iout,*) 'In EELEC'
2824 cd      do i=1,nloctyp
2825 cd        write(iout,*) 'Type',i
2826 cd        write(iout,*) 'B1',B1(:,i)
2827 cd        write(iout,*) 'B2',B2(:,i)
2828 cd        write(iout,*) 'CC',CC(:,:,i)
2829 cd        write(iout,*) 'DD',DD(:,:,i)
2830 cd        write(iout,*) 'EE',EE(:,:,i)
2831 cd      enddo
2832 cd      call check_vecgrad
2833 cd      stop
2834       if (icheckgrad.eq.1) then
2835         do i=1,nres-1
2836           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2837           do k=1,3
2838             dc_norm(k,i)=dc(k,i)*fac
2839           enddo
2840 c          write (iout,*) 'i',i,' fac',fac
2841         enddo
2842       endif
2843       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2844      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2845      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2846 c        call vec_and_deriv
2847 #ifdef TIMING
2848         time01=MPI_Wtime()
2849 #endif
2850         call set_matrices
2851 #ifdef TIMING
2852         time_mat=time_mat+MPI_Wtime()-time01
2853 #endif
2854       endif
2855 cd      do i=1,nres-1
2856 cd        write (iout,*) 'i=',i
2857 cd        do k=1,3
2858 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2859 cd        enddo
2860 cd        do k=1,3
2861 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2862 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2863 cd        enddo
2864 cd      enddo
2865       t_eelecij=0.0d0
2866       ees=0.0D0
2867       evdw1=0.0D0
2868       eel_loc=0.0d0
2869       eello_turn3=0.0d0
2870       eello_turn4=0.0d0
2871       ind=0
2872       do i=1,nres
2873         num_cont_hb(i)=0
2874       enddo
2875 cd      print '(a)','Enter EELEC'
2876 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2877       do i=1,nres
2878         gel_loc_loc(i)=0.0d0
2879         gcorr_loc(i)=0.0d0
2880       enddo
2881 c
2882 c
2883 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2884 C
2885 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2886 C
2887       do i=iturn3_start,iturn3_end
2888         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2889      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2890         dxi=dc(1,i)
2891         dyi=dc(2,i)
2892         dzi=dc(3,i)
2893         dx_normi=dc_norm(1,i)
2894         dy_normi=dc_norm(2,i)
2895         dz_normi=dc_norm(3,i)
2896         xmedi=c(1,i)+0.5d0*dxi
2897         ymedi=c(2,i)+0.5d0*dyi
2898         zmedi=c(3,i)+0.5d0*dzi
2899         num_conti=0
2900         call eelecij(i,i+2,ees,evdw1,eel_loc)
2901         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2902         num_cont_hb(i)=num_conti
2903       enddo
2904       do i=iturn4_start,iturn4_end
2905         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2906      &    .or. itype(i+3).eq.ntyp1
2907      &    .or. itype(i+4).eq.ntyp1) cycle
2908         dxi=dc(1,i)
2909         dyi=dc(2,i)
2910         dzi=dc(3,i)
2911         dx_normi=dc_norm(1,i)
2912         dy_normi=dc_norm(2,i)
2913         dz_normi=dc_norm(3,i)
2914         xmedi=c(1,i)+0.5d0*dxi
2915         ymedi=c(2,i)+0.5d0*dyi
2916         zmedi=c(3,i)+0.5d0*dzi
2917         num_conti=num_cont_hb(i)
2918 c        write(iout,*) "JESTEM W PETLI"
2919         call eelecij(i,i+3,ees,evdw1,eel_loc)
2920         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2921      &   call eturn4(i,eello_turn4)
2922         num_cont_hb(i)=num_conti
2923       enddo   ! i
2924 c
2925 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2926 c
2927       do i=iatel_s,iatel_e
2928 c       do i=7,7
2929         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2930         dxi=dc(1,i)
2931         dyi=dc(2,i)
2932         dzi=dc(3,i)
2933         dx_normi=dc_norm(1,i)
2934         dy_normi=dc_norm(2,i)
2935         dz_normi=dc_norm(3,i)
2936         xmedi=c(1,i)+0.5d0*dxi
2937         ymedi=c(2,i)+0.5d0*dyi
2938         zmedi=c(3,i)+0.5d0*dzi
2939 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2940         num_conti=num_cont_hb(i)
2941         do j=ielstart(i),ielend(i)
2942 c         do j=13,13
2943 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2944           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2945           call eelecij(i,j,ees,evdw1,eel_loc)
2946         enddo ! j
2947         num_cont_hb(i)=num_conti
2948       enddo   ! i
2949 c      write (iout,*) "Number of loop steps in EELEC:",ind
2950 cd      do i=1,nres
2951 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2952 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2953 cd      enddo
2954 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2955 ccc      eel_loc=eel_loc+eello_turn3
2956 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2957       return
2958       end
2959 C-------------------------------------------------------------------------------
2960       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2961       implicit real*8 (a-h,o-z)
2962       include 'DIMENSIONS'
2963 #ifdef MPI
2964       include "mpif.h"
2965 #endif
2966       include 'COMMON.CONTROL'
2967       include 'COMMON.IOUNITS'
2968       include 'COMMON.GEO'
2969       include 'COMMON.VAR'
2970       include 'COMMON.LOCAL'
2971       include 'COMMON.CHAIN'
2972       include 'COMMON.DERIV'
2973       include 'COMMON.INTERACT'
2974       include 'COMMON.CONTACTS'
2975       include 'COMMON.TORSION'
2976       include 'COMMON.VECTORS'
2977       include 'COMMON.FFIELD'
2978       include 'COMMON.TIME1'
2979       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2980      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2981       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2982      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2983      &    gmuij2(4),gmuji2(4)
2984       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2985      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2986      &    num_conti,j1,j2
2987 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2988 #ifdef MOMENT
2989       double precision scal_el /1.0d0/
2990 #else
2991       double precision scal_el /0.5d0/
2992 #endif
2993 C 12/13/98
2994 C 13-go grudnia roku pamietnego...
2995       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2996      &                   0.0d0,1.0d0,0.0d0,
2997      &                   0.0d0,0.0d0,1.0d0/
2998 c          time00=MPI_Wtime()
2999 cd      write (iout,*) "eelecij",i,j
3000 c          ind=ind+1
3001           iteli=itel(i)
3002           itelj=itel(j)
3003           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3004           aaa=app(iteli,itelj)
3005           bbb=bpp(iteli,itelj)
3006           ael6i=ael6(iteli,itelj)
3007           ael3i=ael3(iteli,itelj)
3008           dxj=dc(1,j)
3009           dyj=dc(2,j)
3010           dzj=dc(3,j)
3011           dx_normj=dc_norm(1,j)
3012           dy_normj=dc_norm(2,j)
3013           dz_normj=dc_norm(3,j)
3014           xj=c(1,j)+0.5D0*dxj-xmedi
3015           yj=c(2,j)+0.5D0*dyj-ymedi
3016           zj=c(3,j)+0.5D0*dzj-zmedi
3017           rij=xj*xj+yj*yj+zj*zj
3018           rrmij=1.0D0/rij
3019           rij=dsqrt(rij)
3020           rmij=1.0D0/rij
3021           r3ij=rrmij*rmij
3022           r6ij=r3ij*r3ij
3023           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3024           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3025           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3026           fac=cosa-3.0D0*cosb*cosg
3027           ev1=aaa*r6ij*r6ij
3028 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3029           if (j.eq.i+2) ev1=scal_el*ev1
3030           ev2=bbb*r6ij
3031           fac3=ael6i*r6ij
3032           fac4=ael3i*r3ij
3033           evdwij=ev1+ev2
3034           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3035           el2=fac4*fac
3036           eesij=el1+el2
3037 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3038           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3039           ees=ees+eesij
3040           evdw1=evdw1+evdwij
3041 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3042 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3043 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3044 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3045
3046           if (energy_dec) then
3047               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3048      &'evdw1',i,j,evdwij
3049      &,iteli,itelj,aaa,evdw1
3050               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3051           endif
3052
3053 C
3054 C Calculate contributions to the Cartesian gradient.
3055 C
3056 #ifdef SPLITELE
3057           facvdw=-6*rrmij*(ev1+evdwij)
3058           facel=-3*rrmij*(el1+eesij)
3059           fac1=fac
3060           erij(1)=xj*rmij
3061           erij(2)=yj*rmij
3062           erij(3)=zj*rmij
3063 *
3064 * Radial derivatives. First process both termini of the fragment (i,j)
3065 *
3066           ggg(1)=facel*xj
3067           ggg(2)=facel*yj
3068           ggg(3)=facel*zj
3069 c          do k=1,3
3070 c            ghalf=0.5D0*ggg(k)
3071 c            gelc(k,i)=gelc(k,i)+ghalf
3072 c            gelc(k,j)=gelc(k,j)+ghalf
3073 c          enddo
3074 c 9/28/08 AL Gradient compotents will be summed only at the end
3075           do k=1,3
3076             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3077             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3078           enddo
3079 *
3080 * Loop over residues i+1 thru j-1.
3081 *
3082 cgrad          do k=i+1,j-1
3083 cgrad            do l=1,3
3084 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3085 cgrad            enddo
3086 cgrad          enddo
3087           ggg(1)=facvdw*xj
3088           ggg(2)=facvdw*yj
3089           ggg(3)=facvdw*zj
3090 c          do k=1,3
3091 c            ghalf=0.5D0*ggg(k)
3092 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3093 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3094 c          enddo
3095 c 9/28/08 AL Gradient compotents will be summed only at the end
3096           do k=1,3
3097             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3098             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3099           enddo
3100 *
3101 * Loop over residues i+1 thru j-1.
3102 *
3103 cgrad          do k=i+1,j-1
3104 cgrad            do l=1,3
3105 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3106 cgrad            enddo
3107 cgrad          enddo
3108 #else
3109           facvdw=ev1+evdwij
3110           facel=el1+eesij
3111           fac1=fac
3112           fac=-3*rrmij*(facvdw+facvdw+facel)
3113           erij(1)=xj*rmij
3114           erij(2)=yj*rmij
3115           erij(3)=zj*rmij
3116 *
3117 * Radial derivatives. First process both termini of the fragment (i,j)
3118 *
3119           ggg(1)=fac*xj
3120           ggg(2)=fac*yj
3121           ggg(3)=fac*zj
3122 c          do k=1,3
3123 c            ghalf=0.5D0*ggg(k)
3124 c            gelc(k,i)=gelc(k,i)+ghalf
3125 c            gelc(k,j)=gelc(k,j)+ghalf
3126 c          enddo
3127 c 9/28/08 AL Gradient compotents will be summed only at the end
3128           do k=1,3
3129             gelc_long(k,j)=gelc(k,j)+ggg(k)
3130             gelc_long(k,i)=gelc(k,i)-ggg(k)
3131           enddo
3132 *
3133 * Loop over residues i+1 thru j-1.
3134 *
3135 cgrad          do k=i+1,j-1
3136 cgrad            do l=1,3
3137 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3138 cgrad            enddo
3139 cgrad          enddo
3140 c 9/28/08 AL Gradient compotents will be summed only at the end
3141           ggg(1)=facvdw*xj
3142           ggg(2)=facvdw*yj
3143           ggg(3)=facvdw*zj
3144           do k=1,3
3145             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3146             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3147           enddo
3148 #endif
3149 *
3150 * Angular part
3151 *
3152           ecosa=2.0D0*fac3*fac1+fac4
3153           fac4=-3.0D0*fac4
3154           fac3=-6.0D0*fac3
3155           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3156           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3157           do k=1,3
3158             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3159             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3160           enddo
3161 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3162 cd   &          (dcosg(k),k=1,3)
3163           do k=1,3
3164             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3165           enddo
3166 c          do k=1,3
3167 c            ghalf=0.5D0*ggg(k)
3168 c            gelc(k,i)=gelc(k,i)+ghalf
3169 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3170 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3171 c            gelc(k,j)=gelc(k,j)+ghalf
3172 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3173 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3174 c          enddo
3175 cgrad          do k=i+1,j-1
3176 cgrad            do l=1,3
3177 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3178 cgrad            enddo
3179 cgrad          enddo
3180           do k=1,3
3181             gelc(k,i)=gelc(k,i)
3182      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3183      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3184             gelc(k,j)=gelc(k,j)
3185      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3186      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3187             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3188             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3189           enddo
3190           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3191      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3192      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3193 C
3194 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3195 C   energy of a peptide unit is assumed in the form of a second-order
3196 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3197 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3198 C   are computed for EVERY pair of non-contiguous peptide groups.
3199 C
3200
3201           if (j.lt.nres-1) then
3202             j1=j+1
3203             j2=j-1
3204           else
3205             j1=j-1
3206             j2=j-2
3207           endif
3208           kkk=0
3209           lll=0
3210           do k=1,2
3211             do l=1,2
3212               kkk=kkk+1
3213               muij(kkk)=mu(k,i)*mu(l,j)
3214 #ifdef NEWCORR
3215              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3216 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(k,i),k,i
3217              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3218              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3219 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(l,j),l,j
3220              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3221 #endif
3222             enddo
3223           enddo
3224 cd         write (iout,*) 'EELEC: i',i,' j',j
3225 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3226 cd          write(iout,*) 'muij',muij
3227           ury=scalar(uy(1,i),erij)
3228           urz=scalar(uz(1,i),erij)
3229           vry=scalar(uy(1,j),erij)
3230           vrz=scalar(uz(1,j),erij)
3231           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3232           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3233           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3234           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3235           fac=dsqrt(-ael6i)*r3ij
3236           a22=a22*fac
3237           a23=a23*fac
3238           a32=a32*fac
3239           a33=a33*fac
3240 cd          write (iout,'(4i5,4f10.5)')
3241 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3242 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3243 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3244 cd     &      uy(:,j),uz(:,j)
3245 cd          write (iout,'(4f10.5)')
3246 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3247 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3248 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3249 cd           write (iout,'(9f10.5/)')
3250 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3251 C Derivatives of the elements of A in virtual-bond vectors
3252           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3253           do k=1,3
3254             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3255             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3256             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3257             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3258             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3259             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3260             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3261             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3262             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3263             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3264             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3265             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3266           enddo
3267 C Compute radial contributions to the gradient
3268           facr=-3.0d0*rrmij
3269           a22der=a22*facr
3270           a23der=a23*facr
3271           a32der=a32*facr
3272           a33der=a33*facr
3273           agg(1,1)=a22der*xj
3274           agg(2,1)=a22der*yj
3275           agg(3,1)=a22der*zj
3276           agg(1,2)=a23der*xj
3277           agg(2,2)=a23der*yj
3278           agg(3,2)=a23der*zj
3279           agg(1,3)=a32der*xj
3280           agg(2,3)=a32der*yj
3281           agg(3,3)=a32der*zj
3282           agg(1,4)=a33der*xj
3283           agg(2,4)=a33der*yj
3284           agg(3,4)=a33der*zj
3285 C Add the contributions coming from er
3286           fac3=-3.0d0*fac
3287           do k=1,3
3288             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3289             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3290             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3291             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3292           enddo
3293           do k=1,3
3294 C Derivatives in DC(i)
3295 cgrad            ghalf1=0.5d0*agg(k,1)
3296 cgrad            ghalf2=0.5d0*agg(k,2)
3297 cgrad            ghalf3=0.5d0*agg(k,3)
3298 cgrad            ghalf4=0.5d0*agg(k,4)
3299             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3300      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3301             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3302      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3303             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3304      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3305             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3306      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3307 C Derivatives in DC(i+1)
3308             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3309      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3310             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3311      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3312             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3313      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3314             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3315      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3316 C Derivatives in DC(j)
3317             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3318      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3319             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3320      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3321             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3322      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3323             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3324      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3325 C Derivatives in DC(j+1) or DC(nres-1)
3326             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3327      &      -3.0d0*vryg(k,3)*ury)
3328             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3329      &      -3.0d0*vrzg(k,3)*ury)
3330             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3331      &      -3.0d0*vryg(k,3)*urz)
3332             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3333      &      -3.0d0*vrzg(k,3)*urz)
3334 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3335 cgrad              do l=1,4
3336 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3337 cgrad              enddo
3338 cgrad            endif
3339           enddo
3340           acipa(1,1)=a22
3341           acipa(1,2)=a23
3342           acipa(2,1)=a32
3343           acipa(2,2)=a33
3344           a22=-a22
3345           a23=-a23
3346           do l=1,2
3347             do k=1,3
3348               agg(k,l)=-agg(k,l)
3349               aggi(k,l)=-aggi(k,l)
3350               aggi1(k,l)=-aggi1(k,l)
3351               aggj(k,l)=-aggj(k,l)
3352               aggj1(k,l)=-aggj1(k,l)
3353             enddo
3354           enddo
3355           if (j.lt.nres-1) then
3356             a22=-a22
3357             a32=-a32
3358             do l=1,3,2
3359               do k=1,3
3360                 agg(k,l)=-agg(k,l)
3361                 aggi(k,l)=-aggi(k,l)
3362                 aggi1(k,l)=-aggi1(k,l)
3363                 aggj(k,l)=-aggj(k,l)
3364                 aggj1(k,l)=-aggj1(k,l)
3365               enddo
3366             enddo
3367           else
3368             a22=-a22
3369             a23=-a23
3370             a32=-a32
3371             a33=-a33
3372             do l=1,4
3373               do k=1,3
3374                 agg(k,l)=-agg(k,l)
3375                 aggi(k,l)=-aggi(k,l)
3376                 aggi1(k,l)=-aggi1(k,l)
3377                 aggj(k,l)=-aggj(k,l)
3378                 aggj1(k,l)=-aggj1(k,l)
3379               enddo
3380             enddo
3381           endif
3382           ENDIF ! WCORR
3383           IF (wel_loc.gt.0.0d0) THEN
3384 c           if ((i.eq.8).and.(j.eq.14)) then
3385 C Contribution to the local-electrostatic energy coming from the i-j pair
3386           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3387      &     +a33*muij(4)
3388 C Calculate patrial derivative for theta angle
3389 #ifdef NEWCORR
3390          geel_loc_ij=a22*gmuij1(1)
3391      &     +a23*gmuij1(2)
3392      &     +a32*gmuij1(3)
3393      &     +a33*gmuij1(4)
3394 c         write(iout,*) "derivative over thatai"
3395 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3396 c     &   a33*gmuij1(4)
3397          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3398      &      geel_loc_ij*wel_loc
3399 c         write(iout,*) "derivative over thatai-1"
3400 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3401 c     &   a33*gmuij2(4)
3402          geel_loc_ij=a22*gmuij2(1)+a23*gmuij2(2)+a32*gmuij2(3)
3403      &     +a33*gmuij2(4)
3404          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3405      &      geel_loc_ij*wel_loc
3406          geel_loc_ji=a22*gmuji1(1)+a23*gmuji1(2)+a32*gmuji1(3)
3407      &     +a33*gmuji1(4)
3408 c         write(iout,*) "derivative over thataj"
3409 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3410 c     &   a33*gmuji1(4)
3411
3412          gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3413      &      geel_loc_ji*wel_loc
3414          geel_loc_ji=a22*gmuji2(1)+a23*gmuji2(2)+a32*gmuji2(3)
3415      &     +a33*gmuji2(4)
3416 c         write(iout,*) "derivative over thataj-1"
3417 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3418 c     &   a33*gmuji2(4)
3419          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3420      &      geel_loc_ji*wel_loc
3421 #endif
3422 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3423
3424           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3425      &            'eelloc',i,j,eel_loc_ij
3426 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3427
3428           eel_loc=eel_loc+eel_loc_ij
3429 C Partial derivatives in virtual-bond dihedral angles gamma
3430           if (i.gt.1)
3431      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3432      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3433      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3434           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3435      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3436      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3437 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3438           do l=1,3
3439             ggg(l)=agg(l,1)*muij(1)+
3440      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3441             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3442             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3443 cgrad            ghalf=0.5d0*ggg(l)
3444 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3445 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3446           enddo
3447 cgrad          do k=i+1,j2
3448 cgrad            do l=1,3
3449 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3450 cgrad            enddo
3451 cgrad          enddo
3452 C Remaining derivatives of eello
3453           do l=1,3
3454             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3455      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3456             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3457      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3458             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3459      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3460             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3461      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3462           enddo
3463 c          endif
3464           ENDIF
3465 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3466 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3467           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3468      &       .and. num_conti.le.maxconts) then
3469 c            write (iout,*) i,j," entered corr"
3470 C
3471 C Calculate the contact function. The ith column of the array JCONT will
3472 C contain the numbers of atoms that make contacts with the atom I (of numbers
3473 C greater than I). The arrays FACONT and GACONT will contain the values of
3474 C the contact function and its derivative.
3475 c           r0ij=1.02D0*rpp(iteli,itelj)
3476 c           r0ij=1.11D0*rpp(iteli,itelj)
3477             r0ij=2.20D0*rpp(iteli,itelj)
3478 c           r0ij=1.55D0*rpp(iteli,itelj)
3479             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3480             if (fcont.gt.0.0D0) then
3481               num_conti=num_conti+1
3482               if (num_conti.gt.maxconts) then
3483                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3484      &                         ' will skip next contacts for this conf.'
3485               else
3486                 jcont_hb(num_conti,i)=j
3487 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3488 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3489                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3490      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3491 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3492 C  terms.
3493                 d_cont(num_conti,i)=rij
3494 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3495 C     --- Electrostatic-interaction matrix ---
3496                 a_chuj(1,1,num_conti,i)=a22
3497                 a_chuj(1,2,num_conti,i)=a23
3498                 a_chuj(2,1,num_conti,i)=a32
3499                 a_chuj(2,2,num_conti,i)=a33
3500 C     --- Gradient of rij
3501                 do kkk=1,3
3502                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3503                 enddo
3504                 kkll=0
3505                 do k=1,2
3506                   do l=1,2
3507                     kkll=kkll+1
3508                     do m=1,3
3509                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3510                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3511                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3512                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3513                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3514                     enddo
3515                   enddo
3516                 enddo
3517                 ENDIF
3518                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3519 C Calculate contact energies
3520                 cosa4=4.0D0*cosa
3521                 wij=cosa-3.0D0*cosb*cosg
3522                 cosbg1=cosb+cosg
3523                 cosbg2=cosb-cosg
3524 c               fac3=dsqrt(-ael6i)/r0ij**3
3525                 fac3=dsqrt(-ael6i)*r3ij
3526 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3527                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3528                 if (ees0tmp.gt.0) then
3529                   ees0pij=dsqrt(ees0tmp)
3530                 else
3531                   ees0pij=0
3532                 endif
3533 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3534                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3535                 if (ees0tmp.gt.0) then
3536                   ees0mij=dsqrt(ees0tmp)
3537                 else
3538                   ees0mij=0
3539                 endif
3540 c               ees0mij=0.0D0
3541                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3542                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3543 C Diagnostics. Comment out or remove after debugging!
3544 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3545 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3546 c               ees0m(num_conti,i)=0.0D0
3547 C End diagnostics.
3548 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3549 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3550 C Angular derivatives of the contact function
3551                 ees0pij1=fac3/ees0pij
3552                 ees0mij1=fac3/ees0mij
3553                 fac3p=-3.0D0*fac3*rrmij
3554                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3555                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3556 c               ees0mij1=0.0D0
3557                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3558                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3559                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3560                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3561                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3562                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3563                 ecosap=ecosa1+ecosa2
3564                 ecosbp=ecosb1+ecosb2
3565                 ecosgp=ecosg1+ecosg2
3566                 ecosam=ecosa1-ecosa2
3567                 ecosbm=ecosb1-ecosb2
3568                 ecosgm=ecosg1-ecosg2
3569 C Diagnostics
3570 c               ecosap=ecosa1
3571 c               ecosbp=ecosb1
3572 c               ecosgp=ecosg1
3573 c               ecosam=0.0D0
3574 c               ecosbm=0.0D0
3575 c               ecosgm=0.0D0
3576 C End diagnostics
3577                 facont_hb(num_conti,i)=fcont
3578                 fprimcont=fprimcont/rij
3579 cd              facont_hb(num_conti,i)=1.0D0
3580 C Following line is for diagnostics.
3581 cd              fprimcont=0.0D0
3582                 do k=1,3
3583                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3584                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3585                 enddo
3586                 do k=1,3
3587                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3588                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3589                 enddo
3590                 gggp(1)=gggp(1)+ees0pijp*xj
3591                 gggp(2)=gggp(2)+ees0pijp*yj
3592                 gggp(3)=gggp(3)+ees0pijp*zj
3593                 gggm(1)=gggm(1)+ees0mijp*xj
3594                 gggm(2)=gggm(2)+ees0mijp*yj
3595                 gggm(3)=gggm(3)+ees0mijp*zj
3596 C Derivatives due to the contact function
3597                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3598                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3599                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3600                 do k=1,3
3601 c
3602 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3603 c          following the change of gradient-summation algorithm.
3604 c
3605 cgrad                  ghalfp=0.5D0*gggp(k)
3606 cgrad                  ghalfm=0.5D0*gggm(k)
3607                   gacontp_hb1(k,num_conti,i)=!ghalfp
3608      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3609      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3610                   gacontp_hb2(k,num_conti,i)=!ghalfp
3611      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3612      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3613                   gacontp_hb3(k,num_conti,i)=gggp(k)
3614                   gacontm_hb1(k,num_conti,i)=!ghalfm
3615      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3616      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3617                   gacontm_hb2(k,num_conti,i)=!ghalfm
3618      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3619      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3620                   gacontm_hb3(k,num_conti,i)=gggm(k)
3621                 enddo
3622 C Diagnostics. Comment out or remove after debugging!
3623 cdiag           do k=1,3
3624 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3625 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3626 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3627 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3628 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3629 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3630 cdiag           enddo
3631               ENDIF ! wcorr
3632               endif  ! num_conti.le.maxconts
3633             endif  ! fcont.gt.0
3634           endif    ! j.gt.i+1
3635           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3636             do k=1,4
3637               do l=1,3
3638                 ghalf=0.5d0*agg(l,k)
3639                 aggi(l,k)=aggi(l,k)+ghalf
3640                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3641                 aggj(l,k)=aggj(l,k)+ghalf
3642               enddo
3643             enddo
3644             if (j.eq.nres-1 .and. i.lt.j-2) then
3645               do k=1,4
3646                 do l=1,3
3647                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3648                 enddo
3649               enddo
3650             endif
3651           endif
3652 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3653       return
3654       end
3655 C-----------------------------------------------------------------------------
3656       subroutine eturn3(i,eello_turn3)
3657 C Third- and fourth-order contributions from turns
3658       implicit real*8 (a-h,o-z)
3659       include 'DIMENSIONS'
3660       include 'COMMON.IOUNITS'
3661       include 'COMMON.GEO'
3662       include 'COMMON.VAR'
3663       include 'COMMON.LOCAL'
3664       include 'COMMON.CHAIN'
3665       include 'COMMON.DERIV'
3666       include 'COMMON.INTERACT'
3667       include 'COMMON.CONTACTS'
3668       include 'COMMON.TORSION'
3669       include 'COMMON.VECTORS'
3670       include 'COMMON.FFIELD'
3671       include 'COMMON.CONTROL'
3672       dimension ggg(3)
3673       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3674      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3675      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3676      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3677      &  auxgmat2(2,2),auxgmatt2(2,2)
3678       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3679      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3680       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3681      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3682      &    num_conti,j1,j2
3683       j=i+2
3684 c      write (iout,*) "eturn3",i,j,j1,j2
3685       a_temp(1,1)=a22
3686       a_temp(1,2)=a23
3687       a_temp(2,1)=a32
3688       a_temp(2,2)=a33
3689 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3690 C
3691 C               Third-order contributions
3692 C
3693 C                 (i+2)o----(i+3)
3694 C                      | |
3695 C                      | |
3696 C                 (i+1)o----i
3697 C
3698 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3699 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3700         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3701 c auxalary matices for theta gradient
3702 c auxalary matrix for i+1 and constant i+2
3703         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3704 c auxalary matrix for i+2 and constant i+1
3705         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3706         call transpose2(auxmat(1,1),auxmat1(1,1))
3707         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3708         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3709         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3710         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3711         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3712         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3713 C Derivatives in theta
3714         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3715      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3716         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3717      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3718
3719         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3720      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3721 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3722 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3723 cd     &    ' eello_turn3_num',4*eello_turn3_num
3724 C Derivatives in gamma(i)
3725         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3726         call transpose2(auxmat2(1,1),auxmat3(1,1))
3727         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3728         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3729 C Derivatives in gamma(i+1)
3730         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3731         call transpose2(auxmat2(1,1),auxmat3(1,1))
3732         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3733         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3734      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3735 C Cartesian derivatives
3736         do l=1,3
3737 c            ghalf1=0.5d0*agg(l,1)
3738 c            ghalf2=0.5d0*agg(l,2)
3739 c            ghalf3=0.5d0*agg(l,3)
3740 c            ghalf4=0.5d0*agg(l,4)
3741           a_temp(1,1)=aggi(l,1)!+ghalf1
3742           a_temp(1,2)=aggi(l,2)!+ghalf2
3743           a_temp(2,1)=aggi(l,3)!+ghalf3
3744           a_temp(2,2)=aggi(l,4)!+ghalf4
3745           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3746           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3747      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3748           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3749           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3750           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3751           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3752           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3753           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3754      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3755           a_temp(1,1)=aggj(l,1)!+ghalf1
3756           a_temp(1,2)=aggj(l,2)!+ghalf2
3757           a_temp(2,1)=aggj(l,3)!+ghalf3
3758           a_temp(2,2)=aggj(l,4)!+ghalf4
3759           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3760           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3761      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3762           a_temp(1,1)=aggj1(l,1)
3763           a_temp(1,2)=aggj1(l,2)
3764           a_temp(2,1)=aggj1(l,3)
3765           a_temp(2,2)=aggj1(l,4)
3766           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3768      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3769         enddo
3770       return
3771       end
3772 C-------------------------------------------------------------------------------
3773       subroutine eturn4(i,eello_turn4)
3774 C Third- and fourth-order contributions from turns
3775       implicit real*8 (a-h,o-z)
3776       include 'DIMENSIONS'
3777       include 'COMMON.IOUNITS'
3778       include 'COMMON.GEO'
3779       include 'COMMON.VAR'
3780       include 'COMMON.LOCAL'
3781       include 'COMMON.CHAIN'
3782       include 'COMMON.DERIV'
3783       include 'COMMON.INTERACT'
3784       include 'COMMON.CONTACTS'
3785       include 'COMMON.TORSION'
3786       include 'COMMON.VECTORS'
3787       include 'COMMON.FFIELD'
3788       include 'COMMON.CONTROL'
3789       dimension ggg(3)
3790       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3791      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3792      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3793      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3794      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3795      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3796      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3797       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3798      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3799       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3800      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3801      &    num_conti,j1,j2
3802       j=i+3
3803 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3804 C
3805 C               Fourth-order contributions
3806 C
3807 C                 (i+3)o----(i+4)
3808 C                     /  |
3809 C               (i+2)o   |
3810 C                     \  |
3811 C                 (i+1)o----i
3812 C
3813 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3814 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3815 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3816 c        write(iout,*)"WCHODZE W PROGRAM"
3817         a_temp(1,1)=a22
3818         a_temp(1,2)=a23
3819         a_temp(2,1)=a32
3820         a_temp(2,2)=a33
3821         iti1=itortyp(itype(i+1))
3822         iti2=itortyp(itype(i+2))
3823         iti3=itortyp(itype(i+3))
3824 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3825         call transpose2(EUg(1,1,i+1),e1t(1,1))
3826         call transpose2(Eug(1,1,i+2),e2t(1,1))
3827         call transpose2(Eug(1,1,i+3),e3t(1,1))
3828 C Ematrix derivative in theta
3829         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3830         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3831         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3832         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3833 c       eta1 in derivative theta
3834         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3835         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3836 c       auxgvec is derivative of Ub2 so i+3 theta
3837         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3838 c       auxalary matrix of E i+1
3839         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3840 c        s1=0.0
3841 c        gs1=0.0
3842         s1=scalar2(b1(1,i+2),auxvec(1))
3843 c derivative of theta i+2 with constant i+3
3844         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3845 c derivative of theta i+2 with constant i+2
3846         gs32=scalar2(b1(1,i+2),auxgvec(1))
3847 c derivative of E matix in theta of i+1
3848         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3849
3850         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3851 c       ea31 in derivative theta
3852         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3853         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3854 c auxilary matrix auxgvec of Ub2 with constant E matirx
3855         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3856 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3857         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3858
3859 c        s2=0.0
3860 c        gs2=0.0
3861         s2=scalar2(b1(1,i+1),auxvec(1))
3862 c derivative of theta i+1 with constant i+3
3863         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3864 c derivative of theta i+2 with constant i+1
3865         gs21=scalar2(b1(1,i+1),auxgvec(1))
3866 c derivative of theta i+3 with constant i+1
3867         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3868 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3869 c     &  gtb1(1,i+1)
3870         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3871 c two derivatives over diffetent matrices
3872 c gtae3e2 is derivative over i+3
3873         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3874 c ae3gte2 is derivative over i+2
3875         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3876         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3877 c three possible derivative over theta E matices
3878 c i+1
3879         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3880 c i+2
3881         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3882 c i+3
3883         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885
3886         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3887         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3888         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3889
3890         eello_turn4=eello_turn4-(s1+s2+s3)
3891 #ifdef NEWCORR
3892         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3893      &                  -(gs13+gsE13+gsEE1)*wturn4
3894         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3895      &                    -(gs23+gs21+gsEE2)*wturn4
3896         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3897      &                    -(gs32+gsE31+gsEE3)*wturn4
3898 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3899 c     &   gs2
3900 #endif
3901         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3902      &      'eturn4',i,j,-(s1+s2+s3)
3903 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3904 c     &    ' eello_turn4_num',8*eello_turn4_num
3905 C Derivatives in gamma(i)
3906         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3907         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3908         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3909         s1=scalar2(b1(1,i+2),auxvec(1))
3910         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3913 C Derivatives in gamma(i+1)
3914         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3915         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3916         s2=scalar2(b1(1,i+1),auxvec(1))
3917         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3918         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3919         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3920         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3921 C Derivatives in gamma(i+2)
3922         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3923         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3924         s1=scalar2(b1(1,i+2),auxvec(1))
3925         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3926         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3927         s2=scalar2(b1(1,i+1),auxvec(1))
3928         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3929         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3930         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3931         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3932 C Cartesian derivatives
3933 C Derivatives of this turn contributions in DC(i+2)
3934         if (j.lt.nres-1) then
3935           do l=1,3
3936             a_temp(1,1)=agg(l,1)
3937             a_temp(1,2)=agg(l,2)
3938             a_temp(2,1)=agg(l,3)
3939             a_temp(2,2)=agg(l,4)
3940             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3941             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3942             s1=scalar2(b1(1,i+2),auxvec(1))
3943             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3944             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3945             s2=scalar2(b1(1,i+1),auxvec(1))
3946             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3947             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3948             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3949             ggg(l)=-(s1+s2+s3)
3950             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3951           enddo
3952         endif
3953 C Remaining derivatives of this turn contribution
3954         do l=1,3
3955           a_temp(1,1)=aggi(l,1)
3956           a_temp(1,2)=aggi(l,2)
3957           a_temp(2,1)=aggi(l,3)
3958           a_temp(2,2)=aggi(l,4)
3959           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3960           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3961           s1=scalar2(b1(1,i+2),auxvec(1))
3962           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3963           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3964           s2=scalar2(b1(1,i+1),auxvec(1))
3965           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3966           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3967           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3968           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3969           a_temp(1,1)=aggi1(l,1)
3970           a_temp(1,2)=aggi1(l,2)
3971           a_temp(2,1)=aggi1(l,3)
3972           a_temp(2,2)=aggi1(l,4)
3973           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3974           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3975           s1=scalar2(b1(1,i+2),auxvec(1))
3976           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3977           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3978           s2=scalar2(b1(1,i+1),auxvec(1))
3979           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3980           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3981           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3982           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3983           a_temp(1,1)=aggj(l,1)
3984           a_temp(1,2)=aggj(l,2)
3985           a_temp(2,1)=aggj(l,3)
3986           a_temp(2,2)=aggj(l,4)
3987           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3988           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3989           s1=scalar2(b1(1,i+2),auxvec(1))
3990           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3991           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3992           s2=scalar2(b1(1,i+1),auxvec(1))
3993           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3994           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3995           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3996           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3997           a_temp(1,1)=aggj1(l,1)
3998           a_temp(1,2)=aggj1(l,2)
3999           a_temp(2,1)=aggj1(l,3)
4000           a_temp(2,2)=aggj1(l,4)
4001           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4002           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4003           s1=scalar2(b1(1,i+2),auxvec(1))
4004           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4005           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4006           s2=scalar2(b1(1,i+1),auxvec(1))
4007           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4008           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4009           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4010 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4011           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4012         enddo
4013       return
4014       end
4015 C-----------------------------------------------------------------------------
4016       subroutine vecpr(u,v,w)
4017       implicit real*8(a-h,o-z)
4018       dimension u(3),v(3),w(3)
4019       w(1)=u(2)*v(3)-u(3)*v(2)
4020       w(2)=-u(1)*v(3)+u(3)*v(1)
4021       w(3)=u(1)*v(2)-u(2)*v(1)
4022       return
4023       end
4024 C-----------------------------------------------------------------------------
4025       subroutine unormderiv(u,ugrad,unorm,ungrad)
4026 C This subroutine computes the derivatives of a normalized vector u, given
4027 C the derivatives computed without normalization conditions, ugrad. Returns
4028 C ungrad.
4029       implicit none
4030       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4031       double precision vec(3)
4032       double precision scalar
4033       integer i,j
4034 c      write (2,*) 'ugrad',ugrad
4035 c      write (2,*) 'u',u
4036       do i=1,3
4037         vec(i)=scalar(ugrad(1,i),u(1))
4038       enddo
4039 c      write (2,*) 'vec',vec
4040       do i=1,3
4041         do j=1,3
4042           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4043         enddo
4044       enddo
4045 c      write (2,*) 'ungrad',ungrad
4046       return
4047       end
4048 C-----------------------------------------------------------------------------
4049       subroutine escp_soft_sphere(evdw2,evdw2_14)
4050 C
4051 C This subroutine calculates the excluded-volume interaction energy between
4052 C peptide-group centers and side chains and its gradient in virtual-bond and
4053 C side-chain vectors.
4054 C
4055       implicit real*8 (a-h,o-z)
4056       include 'DIMENSIONS'
4057       include 'COMMON.GEO'
4058       include 'COMMON.VAR'
4059       include 'COMMON.LOCAL'
4060       include 'COMMON.CHAIN'
4061       include 'COMMON.DERIV'
4062       include 'COMMON.INTERACT'
4063       include 'COMMON.FFIELD'
4064       include 'COMMON.IOUNITS'
4065       include 'COMMON.CONTROL'
4066       dimension ggg(3)
4067       evdw2=0.0D0
4068       evdw2_14=0.0d0
4069       r0_scp=4.5d0
4070 cd    print '(a)','Enter ESCP'
4071 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4072       do i=iatscp_s,iatscp_e
4073         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4074         iteli=itel(i)
4075         xi=0.5D0*(c(1,i)+c(1,i+1))
4076         yi=0.5D0*(c(2,i)+c(2,i+1))
4077         zi=0.5D0*(c(3,i)+c(3,i+1))
4078
4079         do iint=1,nscp_gr(i)
4080
4081         do j=iscpstart(i,iint),iscpend(i,iint)
4082           if (itype(j).eq.ntyp1) cycle
4083           itypj=iabs(itype(j))
4084 C Uncomment following three lines for SC-p interactions
4085 c         xj=c(1,nres+j)-xi
4086 c         yj=c(2,nres+j)-yi
4087 c         zj=c(3,nres+j)-zi
4088 C Uncomment following three lines for Ca-p interactions
4089           xj=c(1,j)-xi
4090           yj=c(2,j)-yi
4091           zj=c(3,j)-zi
4092           rij=xj*xj+yj*yj+zj*zj
4093           r0ij=r0_scp
4094           r0ijsq=r0ij*r0ij
4095           if (rij.lt.r0ijsq) then
4096             evdwij=0.25d0*(rij-r0ijsq)**2
4097             fac=rij-r0ijsq
4098           else
4099             evdwij=0.0d0
4100             fac=0.0d0
4101           endif
4102           evdw2=evdw2+evdwij
4103 C
4104 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4105 C
4106           ggg(1)=xj*fac
4107           ggg(2)=yj*fac
4108           ggg(3)=zj*fac
4109 cgrad          if (j.lt.i) then
4110 cd          write (iout,*) 'j<i'
4111 C Uncomment following three lines for SC-p interactions
4112 c           do k=1,3
4113 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4114 c           enddo
4115 cgrad          else
4116 cd          write (iout,*) 'j>i'
4117 cgrad            do k=1,3
4118 cgrad              ggg(k)=-ggg(k)
4119 C Uncomment following line for SC-p interactions
4120 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4121 cgrad            enddo
4122 cgrad          endif
4123 cgrad          do k=1,3
4124 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4125 cgrad          enddo
4126 cgrad          kstart=min0(i+1,j)
4127 cgrad          kend=max0(i-1,j-1)
4128 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4129 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4130 cgrad          do k=kstart,kend
4131 cgrad            do l=1,3
4132 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4133 cgrad            enddo
4134 cgrad          enddo
4135           do k=1,3
4136             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4137             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4138           enddo
4139         enddo
4140
4141         enddo ! iint
4142       enddo ! i
4143       return
4144       end
4145 C-----------------------------------------------------------------------------
4146       subroutine escp(evdw2,evdw2_14)
4147 C
4148 C This subroutine calculates the excluded-volume interaction energy between
4149 C peptide-group centers and side chains and its gradient in virtual-bond and
4150 C side-chain vectors.
4151 C
4152       implicit real*8 (a-h,o-z)
4153       include 'DIMENSIONS'
4154       include 'COMMON.GEO'
4155       include 'COMMON.VAR'
4156       include 'COMMON.LOCAL'
4157       include 'COMMON.CHAIN'
4158       include 'COMMON.DERIV'
4159       include 'COMMON.INTERACT'
4160       include 'COMMON.FFIELD'
4161       include 'COMMON.IOUNITS'
4162       include 'COMMON.CONTROL'
4163       dimension ggg(3)
4164       evdw2=0.0D0
4165       evdw2_14=0.0d0
4166 cd    print '(a)','Enter ESCP'
4167 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4168       do i=iatscp_s,iatscp_e
4169         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4170         iteli=itel(i)
4171         xi=0.5D0*(c(1,i)+c(1,i+1))
4172         yi=0.5D0*(c(2,i)+c(2,i+1))
4173         zi=0.5D0*(c(3,i)+c(3,i+1))
4174
4175         do iint=1,nscp_gr(i)
4176
4177         do j=iscpstart(i,iint),iscpend(i,iint)
4178           itypj=iabs(itype(j))
4179           if (itypj.eq.ntyp1) cycle
4180 C Uncomment following three lines for SC-p interactions
4181 c         xj=c(1,nres+j)-xi
4182 c         yj=c(2,nres+j)-yi
4183 c         zj=c(3,nres+j)-zi
4184 C Uncomment following three lines for Ca-p interactions
4185           xj=c(1,j)-xi
4186           yj=c(2,j)-yi
4187           zj=c(3,j)-zi
4188           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4189           fac=rrij**expon2
4190           e1=fac*fac*aad(itypj,iteli)
4191           e2=fac*bad(itypj,iteli)
4192           if (iabs(j-i) .le. 2) then
4193             e1=scal14*e1
4194             e2=scal14*e2
4195             evdw2_14=evdw2_14+e1+e2
4196           endif
4197           evdwij=e1+e2
4198           evdw2=evdw2+evdwij
4199           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4200      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4201      &       bad(itypj,iteli)
4202 C
4203 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4204 C
4205           fac=-(evdwij+e1)*rrij
4206           ggg(1)=xj*fac
4207           ggg(2)=yj*fac
4208           ggg(3)=zj*fac
4209 cgrad          if (j.lt.i) then
4210 cd          write (iout,*) 'j<i'
4211 C Uncomment following three lines for SC-p interactions
4212 c           do k=1,3
4213 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4214 c           enddo
4215 cgrad          else
4216 cd          write (iout,*) 'j>i'
4217 cgrad            do k=1,3
4218 cgrad              ggg(k)=-ggg(k)
4219 C Uncomment following line for SC-p interactions
4220 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4221 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4222 cgrad            enddo
4223 cgrad          endif
4224 cgrad          do k=1,3
4225 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4226 cgrad          enddo
4227 cgrad          kstart=min0(i+1,j)
4228 cgrad          kend=max0(i-1,j-1)
4229 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4230 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4231 cgrad          do k=kstart,kend
4232 cgrad            do l=1,3
4233 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4234 cgrad            enddo
4235 cgrad          enddo
4236           do k=1,3
4237             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4238             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4239           enddo
4240         enddo
4241
4242         enddo ! iint
4243       enddo ! i
4244       do i=1,nct
4245         do j=1,3
4246           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4247           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4248           gradx_scp(j,i)=expon*gradx_scp(j,i)
4249         enddo
4250       enddo
4251 C******************************************************************************
4252 C
4253 C                              N O T E !!!
4254 C
4255 C To save time the factor EXPON has been extracted from ALL components
4256 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4257 C use!
4258 C
4259 C******************************************************************************
4260       return
4261       end
4262 C--------------------------------------------------------------------------
4263       subroutine edis(ehpb)
4264 C
4265 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4266 C
4267       implicit real*8 (a-h,o-z)
4268       include 'DIMENSIONS'
4269       include 'COMMON.SBRIDGE'
4270       include 'COMMON.CHAIN'
4271       include 'COMMON.DERIV'
4272       include 'COMMON.VAR'
4273       include 'COMMON.INTERACT'
4274       include 'COMMON.IOUNITS'
4275       dimension ggg(3)
4276       ehpb=0.0D0
4277 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4278 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4279       if (link_end.eq.0) return
4280       do i=link_start,link_end
4281 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4282 C CA-CA distance used in regularization of structure.
4283         ii=ihpb(i)
4284         jj=jhpb(i)
4285 C iii and jjj point to the residues for which the distance is assigned.
4286         if (ii.gt.nres) then
4287           iii=ii-nres
4288           jjj=jj-nres
4289         else
4290           iii=ii
4291           jjj=jj
4292         endif
4293 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4294 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4295 C    distance and angle dependent SS bond potential.
4296 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4297 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4298 c          if (.not.dyn_ss .and. i.le.nss) then
4299 C 15/02/13 CC dynamic SSbond
4300 C        if (.not.dyn_ss.and.
4301 C     &   ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4302
4303         if (.not.dyn_ss .and. i.le.nss) then
4304 C 15/02/13 CC dynamic SSbond - additional check
4305          if (ii.gt.nres
4306      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4307        call ssbond_ene(iii,jjj,eij)
4308           ehpb=ehpb+2*eij
4309         endif
4310 cd          write (iout,*) "eij",eij
4311         else
4312 C Calculate the distance between the two points and its difference from the
4313 C target distance.
4314         dd=dist(ii,jj)
4315         rdis=dd-dhpb(i)
4316 C Get the force constant corresponding to this distance.
4317         waga=forcon(i)
4318 C Calculate the contribution to energy.
4319         ehpb=ehpb+waga*rdis*rdis
4320 C
4321 C Evaluate gradient.
4322 C
4323         fac=waga*rdis/dd
4324 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4325 cd   &   ' waga=',waga,' fac=',fac
4326         do j=1,3
4327           ggg(j)=fac*(c(j,jj)-c(j,ii))
4328         enddo
4329 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4330 C If this is a SC-SC distance, we need to calculate the contributions to the
4331 C Cartesian gradient in the SC vectors (ghpbx).
4332         if (iii.lt.ii) then
4333           do j=1,3
4334             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4335             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4336           enddo
4337         endif
4338 cgrad        do j=iii,jjj-1
4339 cgrad          do k=1,3
4340 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4341 cgrad          enddo
4342 cgrad        enddo
4343         do k=1,3
4344           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4345           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4346         enddo
4347         endif
4348       enddo
4349       ehpb=0.5D0*ehpb
4350       return
4351       end
4352 C--------------------------------------------------------------------------
4353       subroutine ssbond_ene(i,j,eij)
4354 C
4355 C Calculate the distance and angle dependent SS-bond potential energy
4356 C using a free-energy function derived based on RHF/6-31G** ab initio
4357 C calculations of diethyl disulfide.
4358 C
4359 C A. Liwo and U. Kozlowska, 11/24/03
4360 C
4361       implicit real*8 (a-h,o-z)
4362       include 'DIMENSIONS'
4363       include 'COMMON.SBRIDGE'
4364       include 'COMMON.CHAIN'
4365       include 'COMMON.DERIV'
4366       include 'COMMON.LOCAL'
4367       include 'COMMON.INTERACT'
4368       include 'COMMON.VAR'
4369       include 'COMMON.IOUNITS'
4370       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4371       itypi=iabs(itype(i))
4372       xi=c(1,nres+i)
4373       yi=c(2,nres+i)
4374       zi=c(3,nres+i)
4375       dxi=dc_norm(1,nres+i)
4376       dyi=dc_norm(2,nres+i)
4377       dzi=dc_norm(3,nres+i)
4378 c      dsci_inv=dsc_inv(itypi)
4379       dsci_inv=vbld_inv(nres+i)
4380       itypj=iabs(itype(j))
4381 c      dscj_inv=dsc_inv(itypj)
4382       dscj_inv=vbld_inv(nres+j)
4383       xj=c(1,nres+j)-xi
4384       yj=c(2,nres+j)-yi
4385       zj=c(3,nres+j)-zi
4386       dxj=dc_norm(1,nres+j)
4387       dyj=dc_norm(2,nres+j)
4388       dzj=dc_norm(3,nres+j)
4389       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4390       rij=dsqrt(rrij)
4391       erij(1)=xj*rij
4392       erij(2)=yj*rij
4393       erij(3)=zj*rij
4394       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4395       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4396       om12=dxi*dxj+dyi*dyj+dzi*dzj
4397       do k=1,3
4398         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4399         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4400       enddo
4401       rij=1.0d0/rij
4402       deltad=rij-d0cm
4403       deltat1=1.0d0-om1
4404       deltat2=1.0d0+om2
4405       deltat12=om2-om1+2.0d0
4406       cosphi=om12-om1*om2
4407       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4408      &  +akct*deltad*deltat12
4409      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4410 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4411 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4412 c     &  " deltat12",deltat12," eij",eij
4413       ed=2*akcm*deltad+akct*deltat12
4414       pom1=akct*deltad
4415       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4416       eom1=-2*akth*deltat1-pom1-om2*pom2
4417       eom2= 2*akth*deltat2+pom1-om1*pom2
4418       eom12=pom2
4419       do k=1,3
4420         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4421         ghpbx(k,i)=ghpbx(k,i)-ggk
4422      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4423      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4424         ghpbx(k,j)=ghpbx(k,j)+ggk
4425      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4426      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4427         ghpbc(k,i)=ghpbc(k,i)-ggk
4428         ghpbc(k,j)=ghpbc(k,j)+ggk
4429       enddo
4430 C
4431 C Calculate the components of the gradient in DC and X
4432 C
4433 cgrad      do k=i,j-1
4434 cgrad        do l=1,3
4435 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4436 cgrad        enddo
4437 cgrad      enddo
4438       return
4439       end
4440 C--------------------------------------------------------------------------
4441       subroutine ebond(estr)
4442 c
4443 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4444 c
4445       implicit real*8 (a-h,o-z)
4446       include 'DIMENSIONS'
4447       include 'COMMON.LOCAL'
4448       include 'COMMON.GEO'
4449       include 'COMMON.INTERACT'
4450       include 'COMMON.DERIV'
4451       include 'COMMON.VAR'
4452       include 'COMMON.CHAIN'
4453       include 'COMMON.IOUNITS'
4454       include 'COMMON.NAMES'
4455       include 'COMMON.FFIELD'
4456       include 'COMMON.CONTROL'
4457       include 'COMMON.SETUP'
4458       double precision u(3),ud(3)
4459       estr=0.0d0
4460       estr1=0.0d0
4461       do i=ibondp_start,ibondp_end
4462         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4463           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4464           do j=1,3
4465           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4466      &      *dc(j,i-1)/vbld(i)
4467           enddo
4468           if (energy_dec) write(iout,*)
4469      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4470         else
4471         diff = vbld(i)-vbldp0
4472         if (energy_dec) write (iout,*)
4473      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4474         estr=estr+diff*diff
4475         do j=1,3
4476           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4477         enddo
4478 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4479         endif
4480       enddo
4481       estr=0.5d0*AKP*estr+estr1
4482 c
4483 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4484 c
4485       do i=ibond_start,ibond_end
4486         iti=iabs(itype(i))
4487         if (iti.ne.10 .and. iti.ne.ntyp1) then
4488           nbi=nbondterm(iti)
4489           if (nbi.eq.1) then
4490             diff=vbld(i+nres)-vbldsc0(1,iti)
4491             if (energy_dec) write (iout,*)
4492      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4493      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4494             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4495             do j=1,3
4496               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4497             enddo
4498           else
4499             do j=1,nbi
4500               diff=vbld(i+nres)-vbldsc0(j,iti)
4501               ud(j)=aksc(j,iti)*diff
4502               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4503             enddo
4504             uprod=u(1)
4505             do j=2,nbi
4506               uprod=uprod*u(j)
4507             enddo
4508             usum=0.0d0
4509             usumsqder=0.0d0
4510             do j=1,nbi
4511               uprod1=1.0d0
4512               uprod2=1.0d0
4513               do k=1,nbi
4514                 if (k.ne.j) then
4515                   uprod1=uprod1*u(k)
4516                   uprod2=uprod2*u(k)*u(k)
4517                 endif
4518               enddo
4519               usum=usum+uprod1
4520               usumsqder=usumsqder+ud(j)*uprod2
4521             enddo
4522             estr=estr+uprod/usum
4523             do j=1,3
4524              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4525             enddo
4526           endif
4527         endif
4528       enddo
4529       return
4530       end
4531 #ifdef CRYST_THETA
4532 C--------------------------------------------------------------------------
4533       subroutine ebend(etheta)
4534 C
4535 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4536 C angles gamma and its derivatives in consecutive thetas and gammas.
4537 C
4538       implicit real*8 (a-h,o-z)
4539       include 'DIMENSIONS'
4540       include 'COMMON.LOCAL'
4541       include 'COMMON.GEO'
4542       include 'COMMON.INTERACT'
4543       include 'COMMON.DERIV'
4544       include 'COMMON.VAR'
4545       include 'COMMON.CHAIN'
4546       include 'COMMON.IOUNITS'
4547       include 'COMMON.NAMES'
4548       include 'COMMON.FFIELD'
4549       include 'COMMON.CONTROL'
4550       common /calcthet/ term1,term2,termm,diffak,ratak,
4551      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4552      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4553       double precision y(2),z(2)
4554       delta=0.02d0*pi
4555 c      time11=dexp(-2*time)
4556 c      time12=1.0d0
4557       etheta=0.0D0
4558 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4559       do i=ithet_start,ithet_end
4560         if (itype(i-1).eq.ntyp1) cycle
4561 C Zero the energy function and its derivative at 0 or pi.
4562         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4563         it=itype(i-1)
4564         ichir1=isign(1,itype(i-2))
4565         ichir2=isign(1,itype(i))
4566          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4567          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4568          if (itype(i-1).eq.10) then
4569           itype1=isign(10,itype(i-2))
4570           ichir11=isign(1,itype(i-2))
4571           ichir12=isign(1,itype(i-2))
4572           itype2=isign(10,itype(i))
4573           ichir21=isign(1,itype(i))
4574           ichir22=isign(1,itype(i))
4575          endif
4576
4577         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4578 #ifdef OSF
4579           phii=phi(i)
4580           if (phii.ne.phii) phii=150.0
4581 #else
4582           phii=phi(i)
4583 #endif
4584           y(1)=dcos(phii)
4585           y(2)=dsin(phii)
4586         else
4587           y(1)=0.0D0
4588           y(2)=0.0D0
4589         endif
4590         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4591 #ifdef OSF
4592           phii1=phi(i+1)
4593           if (phii1.ne.phii1) phii1=150.0
4594           phii1=pinorm(phii1)
4595           z(1)=cos(phii1)
4596 #else
4597           phii1=phi(i+1)
4598           z(1)=dcos(phii1)
4599 #endif
4600           z(2)=dsin(phii1)
4601         else
4602           z(1)=0.0D0
4603           z(2)=0.0D0
4604         endif
4605 C Calculate the "mean" value of theta from the part of the distribution
4606 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4607 C In following comments this theta will be referred to as t_c.
4608         thet_pred_mean=0.0d0
4609         do k=1,2
4610             athetk=athet(k,it,ichir1,ichir2)
4611             bthetk=bthet(k,it,ichir1,ichir2)
4612           if (it.eq.10) then
4613              athetk=athet(k,itype1,ichir11,ichir12)
4614              bthetk=bthet(k,itype2,ichir21,ichir22)
4615           endif
4616          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4617         enddo
4618         dthett=thet_pred_mean*ssd
4619         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4620 C Derivatives of the "mean" values in gamma1 and gamma2.
4621         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4622      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4623          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4624      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4625          if (it.eq.10) then
4626       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4627      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4628         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4629      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4630          endif
4631         if (theta(i).gt.pi-delta) then
4632           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4633      &         E_tc0)
4634           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4635           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4636           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4637      &        E_theta)
4638           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4639      &        E_tc)
4640         else if (theta(i).lt.delta) then
4641           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4642           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4643           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4644      &        E_theta)
4645           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4646           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4647      &        E_tc)
4648         else
4649           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4650      &        E_theta,E_tc)
4651         endif
4652         etheta=etheta+ethetai
4653         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4654      &      'ebend',i,ethetai
4655         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4656         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4657         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4658       enddo
4659 C Ufff.... We've done all this!!!
4660       return
4661       end
4662 C---------------------------------------------------------------------------
4663       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4664      &     E_tc)
4665       implicit real*8 (a-h,o-z)
4666       include 'DIMENSIONS'
4667       include 'COMMON.LOCAL'
4668       include 'COMMON.IOUNITS'
4669       common /calcthet/ term1,term2,termm,diffak,ratak,
4670      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4671      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4672 C Calculate the contributions to both Gaussian lobes.
4673 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4674 C The "polynomial part" of the "standard deviation" of this part of
4675 C the distribution.
4676         sig=polthet(3,it)
4677         do j=2,0,-1
4678           sig=sig*thet_pred_mean+polthet(j,it)
4679         enddo
4680 C Derivative of the "interior part" of the "standard deviation of the"
4681 C gamma-dependent Gaussian lobe in t_c.
4682         sigtc=3*polthet(3,it)
4683         do j=2,1,-1
4684           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4685         enddo
4686         sigtc=sig*sigtc
4687 C Set the parameters of both Gaussian lobes of the distribution.
4688 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4689         fac=sig*sig+sigc0(it)
4690         sigcsq=fac+fac
4691         sigc=1.0D0/sigcsq
4692 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4693         sigsqtc=-4.0D0*sigcsq*sigtc
4694 c       print *,i,sig,sigtc,sigsqtc
4695 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4696         sigtc=-sigtc/(fac*fac)
4697 C Following variable is sigma(t_c)**(-2)
4698         sigcsq=sigcsq*sigcsq
4699         sig0i=sig0(it)
4700         sig0inv=1.0D0/sig0i**2
4701         delthec=thetai-thet_pred_mean
4702         delthe0=thetai-theta0i
4703         term1=-0.5D0*sigcsq*delthec*delthec
4704         term2=-0.5D0*sig0inv*delthe0*delthe0
4705 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4706 C NaNs in taking the logarithm. We extract the largest exponent which is added
4707 C to the energy (this being the log of the distribution) at the end of energy
4708 C term evaluation for this virtual-bond angle.
4709         if (term1.gt.term2) then
4710           termm=term1
4711           term2=dexp(term2-termm)
4712           term1=1.0d0
4713         else
4714           termm=term2
4715           term1=dexp(term1-termm)
4716           term2=1.0d0
4717         endif
4718 C The ratio between the gamma-independent and gamma-dependent lobes of
4719 C the distribution is a Gaussian function of thet_pred_mean too.
4720         diffak=gthet(2,it)-thet_pred_mean
4721         ratak=diffak/gthet(3,it)**2
4722         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4723 C Let's differentiate it in thet_pred_mean NOW.
4724         aktc=ak*ratak
4725 C Now put together the distribution terms to make complete distribution.
4726         termexp=term1+ak*term2
4727         termpre=sigc+ak*sig0i
4728 C Contribution of the bending energy from this theta is just the -log of
4729 C the sum of the contributions from the two lobes and the pre-exponential
4730 C factor. Simple enough, isn't it?
4731         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4732 C NOW the derivatives!!!
4733 C 6/6/97 Take into account the deformation.
4734         E_theta=(delthec*sigcsq*term1
4735      &       +ak*delthe0*sig0inv*term2)/termexp
4736         E_tc=((sigtc+aktc*sig0i)/termpre
4737      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4738      &       aktc*term2)/termexp)
4739       return
4740       end
4741 c-----------------------------------------------------------------------------
4742       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4743       implicit real*8 (a-h,o-z)
4744       include 'DIMENSIONS'
4745       include 'COMMON.LOCAL'
4746       include 'COMMON.IOUNITS'
4747       common /calcthet/ term1,term2,termm,diffak,ratak,
4748      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4749      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4750       delthec=thetai-thet_pred_mean
4751       delthe0=thetai-theta0i
4752 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4753       t3 = thetai-thet_pred_mean
4754       t6 = t3**2
4755       t9 = term1
4756       t12 = t3*sigcsq
4757       t14 = t12+t6*sigsqtc
4758       t16 = 1.0d0
4759       t21 = thetai-theta0i
4760       t23 = t21**2
4761       t26 = term2
4762       t27 = t21*t26
4763       t32 = termexp
4764       t40 = t32**2
4765       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4766      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4767      & *(-t12*t9-ak*sig0inv*t27)
4768       return
4769       end
4770 #else
4771 C--------------------------------------------------------------------------
4772       subroutine ebend(etheta)
4773 C
4774 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4775 C angles gamma and its derivatives in consecutive thetas and gammas.
4776 C ab initio-derived potentials from
4777 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4778 C
4779       implicit real*8 (a-h,o-z)
4780       include 'DIMENSIONS'
4781       include 'COMMON.LOCAL'
4782       include 'COMMON.GEO'
4783       include 'COMMON.INTERACT'
4784       include 'COMMON.DERIV'
4785       include 'COMMON.VAR'
4786       include 'COMMON.CHAIN'
4787       include 'COMMON.IOUNITS'
4788       include 'COMMON.NAMES'
4789       include 'COMMON.FFIELD'
4790       include 'COMMON.CONTROL'
4791       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4792      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4793      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4794      & sinph1ph2(maxdouble,maxdouble)
4795       logical lprn /.false./, lprn1 /.false./
4796       etheta=0.0D0
4797       do i=ithet_start,ithet_end
4798         if (itype(i-1).eq.ntyp1) cycle
4799         if (iabs(itype(i+1)).eq.20) iblock=2
4800         if (iabs(itype(i+1)).ne.20) iblock=1
4801         dethetai=0.0d0
4802         dephii=0.0d0
4803         dephii1=0.0d0
4804         theti2=0.5d0*theta(i)
4805         ityp2=ithetyp((itype(i-1)))
4806         do k=1,nntheterm
4807           coskt(k)=dcos(k*theti2)
4808           sinkt(k)=dsin(k*theti2)
4809         enddo
4810         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4811 #ifdef OSF
4812           phii=phi(i)
4813           if (phii.ne.phii) phii=150.0
4814 #else
4815           phii=phi(i)
4816 #endif
4817           ityp1=ithetyp((itype(i-2)))
4818 C propagation of chirality for glycine type
4819           do k=1,nsingle
4820             cosph1(k)=dcos(k*phii)
4821             sinph1(k)=dsin(k*phii)
4822           enddo
4823         else
4824           phii=0.0d0
4825           ityp1=nthetyp+1
4826           do k=1,nsingle
4827             cosph1(k)=0.0d0
4828             sinph1(k)=0.0d0
4829           enddo
4830         endif
4831         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4832 #ifdef OSF
4833           phii1=phi(i+1)
4834           if (phii1.ne.phii1) phii1=150.0
4835           phii1=pinorm(phii1)
4836 #else
4837           phii1=phi(i+1)
4838 #endif
4839           ityp3=ithetyp((itype(i)))
4840           do k=1,nsingle
4841             cosph2(k)=dcos(k*phii1)
4842             sinph2(k)=dsin(k*phii1)
4843           enddo
4844         else
4845           phii1=0.0d0
4846           ityp3=nthetyp+1
4847           do k=1,nsingle
4848             cosph2(k)=0.0d0
4849             sinph2(k)=0.0d0
4850           enddo
4851         endif
4852         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4853         do k=1,ndouble
4854           do l=1,k-1
4855             ccl=cosph1(l)*cosph2(k-l)
4856             ssl=sinph1(l)*sinph2(k-l)
4857             scl=sinph1(l)*cosph2(k-l)
4858             csl=cosph1(l)*sinph2(k-l)
4859             cosph1ph2(l,k)=ccl-ssl
4860             cosph1ph2(k,l)=ccl+ssl
4861             sinph1ph2(l,k)=scl+csl
4862             sinph1ph2(k,l)=scl-csl
4863           enddo
4864         enddo
4865         if (lprn) then
4866         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4867      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4868         write (iout,*) "coskt and sinkt"
4869         do k=1,nntheterm
4870           write (iout,*) k,coskt(k),sinkt(k)
4871         enddo
4872         endif
4873         do k=1,ntheterm
4874           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4875           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4876      &      *coskt(k)
4877           if (lprn)
4878      &    write (iout,*) "k",k,"
4879      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4880      &     " ethetai",ethetai
4881         enddo
4882         if (lprn) then
4883         write (iout,*) "cosph and sinph"
4884         do k=1,nsingle
4885           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4886         enddo
4887         write (iout,*) "cosph1ph2 and sinph2ph2"
4888         do k=2,ndouble
4889           do l=1,k-1
4890             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4891      &         sinph1ph2(l,k),sinph1ph2(k,l)
4892           enddo
4893         enddo
4894         write(iout,*) "ethetai",ethetai
4895         endif
4896         do m=1,ntheterm2
4897           do k=1,nsingle
4898             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4899      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4900      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4901      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4902             ethetai=ethetai+sinkt(m)*aux
4903             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4904             dephii=dephii+k*sinkt(m)*(
4905      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4906      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4907             dephii1=dephii1+k*sinkt(m)*(
4908      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4909      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4910             if (lprn)
4911      &      write (iout,*) "m",m," k",k," bbthet",
4912      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4913      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4914      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4915      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4916           enddo
4917         enddo
4918         if (lprn)
4919      &  write(iout,*) "ethetai",ethetai
4920         do m=1,ntheterm3
4921           do k=2,ndouble
4922             do l=1,k-1
4923               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4924      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4925      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4926      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4927               ethetai=ethetai+sinkt(m)*aux
4928               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4929               dephii=dephii+l*sinkt(m)*(
4930      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4931      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4932      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4933      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4934               dephii1=dephii1+(k-l)*sinkt(m)*(
4935      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4936      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4937      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4938      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4939               if (lprn) then
4940               write (iout,*) "m",m," k",k," l",l," ffthet",
4941      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4942      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4943      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4944      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4945      &            " ethetai",ethetai
4946               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4947      &            cosph1ph2(k,l)*sinkt(m),
4948      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4949               endif
4950             enddo
4951           enddo
4952         enddo
4953 10      continue
4954 c        lprn1=.true.
4955         if (lprn1)
4956      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4957      &   i,theta(i)*rad2deg,phii*rad2deg,
4958      &   phii1*rad2deg,ethetai
4959 c        lprn1=.false.
4960         etheta=etheta+ethetai
4961         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4962         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4963         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4964       enddo
4965       return
4966       end
4967 #endif
4968 #ifdef CRYST_SC
4969 c-----------------------------------------------------------------------------
4970       subroutine esc(escloc)
4971 C Calculate the local energy of a side chain and its derivatives in the
4972 C corresponding virtual-bond valence angles THETA and the spherical angles
4973 C ALPHA and OMEGA.
4974       implicit real*8 (a-h,o-z)
4975       include 'DIMENSIONS'
4976       include 'COMMON.GEO'
4977       include 'COMMON.LOCAL'
4978       include 'COMMON.VAR'
4979       include 'COMMON.INTERACT'
4980       include 'COMMON.DERIV'
4981       include 'COMMON.CHAIN'
4982       include 'COMMON.IOUNITS'
4983       include 'COMMON.NAMES'
4984       include 'COMMON.FFIELD'
4985       include 'COMMON.CONTROL'
4986       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4987      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4988       common /sccalc/ time11,time12,time112,theti,it,nlobit
4989       delta=0.02d0*pi
4990       escloc=0.0D0
4991 c     write (iout,'(a)') 'ESC'
4992       do i=loc_start,loc_end
4993         it=itype(i)
4994         if (it.eq.ntyp1) cycle
4995         if (it.eq.10) goto 1
4996         nlobit=nlob(iabs(it))
4997 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4998 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4999         theti=theta(i+1)-pipol
5000         x(1)=dtan(theti)
5001         x(2)=alph(i)
5002         x(3)=omeg(i)
5003
5004         if (x(2).gt.pi-delta) then
5005           xtemp(1)=x(1)
5006           xtemp(2)=pi-delta
5007           xtemp(3)=x(3)
5008           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5009           xtemp(2)=pi
5010           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5011           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5012      &        escloci,dersc(2))
5013           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5014      &        ddersc0(1),dersc(1))
5015           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5016      &        ddersc0(3),dersc(3))
5017           xtemp(2)=pi-delta
5018           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5019           xtemp(2)=pi
5020           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5021           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5022      &            dersc0(2),esclocbi,dersc02)
5023           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5024      &            dersc12,dersc01)
5025           call splinthet(x(2),0.5d0*delta,ss,ssd)
5026           dersc0(1)=dersc01
5027           dersc0(2)=dersc02
5028           dersc0(3)=0.0d0
5029           do k=1,3
5030             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5031           enddo
5032           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5033 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5034 c    &             esclocbi,ss,ssd
5035           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5036 c         escloci=esclocbi
5037 c         write (iout,*) escloci
5038         else if (x(2).lt.delta) then
5039           xtemp(1)=x(1)
5040           xtemp(2)=delta
5041           xtemp(3)=x(3)
5042           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5043           xtemp(2)=0.0d0
5044           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5045           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5046      &        escloci,dersc(2))
5047           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5048      &        ddersc0(1),dersc(1))
5049           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5050      &        ddersc0(3),dersc(3))
5051           xtemp(2)=delta
5052           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5053           xtemp(2)=0.0d0
5054           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5055           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5056      &            dersc0(2),esclocbi,dersc02)
5057           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5058      &            dersc12,dersc01)
5059           dersc0(1)=dersc01
5060           dersc0(2)=dersc02
5061           dersc0(3)=0.0d0
5062           call splinthet(x(2),0.5d0*delta,ss,ssd)
5063           do k=1,3
5064             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5065           enddo
5066           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5067 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5068 c    &             esclocbi,ss,ssd
5069           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5070 c         write (iout,*) escloci
5071         else
5072           call enesc(x,escloci,dersc,ddummy,.false.)
5073         endif
5074
5075         escloc=escloc+escloci
5076         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5077      &     'escloc',i,escloci
5078 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5079
5080         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5081      &   wscloc*dersc(1)
5082         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5083         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5084     1   continue
5085       enddo
5086       return
5087       end
5088 C---------------------------------------------------------------------------
5089       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5090       implicit real*8 (a-h,o-z)
5091       include 'DIMENSIONS'
5092       include 'COMMON.GEO'
5093       include 'COMMON.LOCAL'
5094       include 'COMMON.IOUNITS'
5095       common /sccalc/ time11,time12,time112,theti,it,nlobit
5096       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5097       double precision contr(maxlob,-1:1)
5098       logical mixed
5099 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5100         escloc_i=0.0D0
5101         do j=1,3
5102           dersc(j)=0.0D0
5103           if (mixed) ddersc(j)=0.0d0
5104         enddo
5105         x3=x(3)
5106
5107 C Because of periodicity of the dependence of the SC energy in omega we have
5108 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5109 C To avoid underflows, first compute & store the exponents.
5110
5111         do iii=-1,1
5112
5113           x(3)=x3+iii*dwapi
5114
5115           do j=1,nlobit
5116             do k=1,3
5117               z(k)=x(k)-censc(k,j,it)
5118             enddo
5119             do k=1,3
5120               Axk=0.0D0
5121               do l=1,3
5122                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5123               enddo
5124               Ax(k,j,iii)=Axk
5125             enddo
5126             expfac=0.0D0
5127             do k=1,3
5128               expfac=expfac+Ax(k,j,iii)*z(k)
5129             enddo
5130             contr(j,iii)=expfac
5131           enddo ! j
5132
5133         enddo ! iii
5134
5135         x(3)=x3
5136 C As in the case of ebend, we want to avoid underflows in exponentiation and
5137 C subsequent NaNs and INFs in energy calculation.
5138 C Find the largest exponent
5139         emin=contr(1,-1)
5140         do iii=-1,1
5141           do j=1,nlobit
5142             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5143           enddo
5144         enddo
5145         emin=0.5D0*emin
5146 cd      print *,'it=',it,' emin=',emin
5147
5148 C Compute the contribution to SC energy and derivatives
5149         do iii=-1,1
5150
5151           do j=1,nlobit
5152 #ifdef OSF
5153             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5154             if(adexp.ne.adexp) adexp=1.0
5155             expfac=dexp(adexp)
5156 #else
5157             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5158 #endif
5159 cd          print *,'j=',j,' expfac=',expfac
5160             escloc_i=escloc_i+expfac
5161             do k=1,3
5162               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5163             enddo
5164             if (mixed) then
5165               do k=1,3,2
5166                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5167      &            +gaussc(k,2,j,it))*expfac
5168               enddo
5169             endif
5170           enddo
5171
5172         enddo ! iii
5173
5174         dersc(1)=dersc(1)/cos(theti)**2
5175         ddersc(1)=ddersc(1)/cos(theti)**2
5176         ddersc(3)=ddersc(3)
5177
5178         escloci=-(dlog(escloc_i)-emin)
5179         do j=1,3
5180           dersc(j)=dersc(j)/escloc_i
5181         enddo
5182         if (mixed) then
5183           do j=1,3,2
5184             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5185           enddo
5186         endif
5187       return
5188       end
5189 C------------------------------------------------------------------------------
5190       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5191       implicit real*8 (a-h,o-z)
5192       include 'DIMENSIONS'
5193       include 'COMMON.GEO'
5194       include 'COMMON.LOCAL'
5195       include 'COMMON.IOUNITS'
5196       common /sccalc/ time11,time12,time112,theti,it,nlobit
5197       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5198       double precision contr(maxlob)
5199       logical mixed
5200
5201       escloc_i=0.0D0
5202
5203       do j=1,3
5204         dersc(j)=0.0D0
5205       enddo
5206
5207       do j=1,nlobit
5208         do k=1,2
5209           z(k)=x(k)-censc(k,j,it)
5210         enddo
5211         z(3)=dwapi
5212         do k=1,3
5213           Axk=0.0D0
5214           do l=1,3
5215             Axk=Axk+gaussc(l,k,j,it)*z(l)
5216           enddo
5217           Ax(k,j)=Axk
5218         enddo
5219         expfac=0.0D0
5220         do k=1,3
5221           expfac=expfac+Ax(k,j)*z(k)
5222         enddo
5223         contr(j)=expfac
5224       enddo ! j
5225
5226 C As in the case of ebend, we want to avoid underflows in exponentiation and
5227 C subsequent NaNs and INFs in energy calculation.
5228 C Find the largest exponent
5229       emin=contr(1)
5230       do j=1,nlobit
5231         if (emin.gt.contr(j)) emin=contr(j)
5232       enddo
5233       emin=0.5D0*emin
5234
5235 C Compute the contribution to SC energy and derivatives
5236
5237       dersc12=0.0d0
5238       do j=1,nlobit
5239         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5240         escloc_i=escloc_i+expfac
5241         do k=1,2
5242           dersc(k)=dersc(k)+Ax(k,j)*expfac
5243         enddo
5244         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5245      &            +gaussc(1,2,j,it))*expfac
5246         dersc(3)=0.0d0
5247       enddo
5248
5249       dersc(1)=dersc(1)/cos(theti)**2
5250       dersc12=dersc12/cos(theti)**2
5251       escloci=-(dlog(escloc_i)-emin)
5252       do j=1,2
5253         dersc(j)=dersc(j)/escloc_i
5254       enddo
5255       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5256       return
5257       end
5258 #else
5259 c----------------------------------------------------------------------------------
5260       subroutine esc(escloc)
5261 C Calculate the local energy of a side chain and its derivatives in the
5262 C corresponding virtual-bond valence angles THETA and the spherical angles
5263 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5264 C added by Urszula Kozlowska. 07/11/2007
5265 C
5266       implicit real*8 (a-h,o-z)
5267       include 'DIMENSIONS'
5268       include 'COMMON.GEO'
5269       include 'COMMON.LOCAL'
5270       include 'COMMON.VAR'
5271       include 'COMMON.SCROT'
5272       include 'COMMON.INTERACT'
5273       include 'COMMON.DERIV'
5274       include 'COMMON.CHAIN'
5275       include 'COMMON.IOUNITS'
5276       include 'COMMON.NAMES'
5277       include 'COMMON.FFIELD'
5278       include 'COMMON.CONTROL'
5279       include 'COMMON.VECTORS'
5280       double precision x_prime(3),y_prime(3),z_prime(3)
5281      &    , sumene,dsc_i,dp2_i,x(65),
5282      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5283      &    de_dxx,de_dyy,de_dzz,de_dt
5284       double precision s1_t,s1_6_t,s2_t,s2_6_t
5285       double precision
5286      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5287      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5288      & dt_dCi(3),dt_dCi1(3)
5289       common /sccalc/ time11,time12,time112,theti,it,nlobit
5290       delta=0.02d0*pi
5291       escloc=0.0D0
5292       do i=loc_start,loc_end
5293         if (itype(i).eq.ntyp1) cycle
5294         costtab(i+1) =dcos(theta(i+1))
5295         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5296         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5297         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5298         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5299         cosfac=dsqrt(cosfac2)
5300         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5301         sinfac=dsqrt(sinfac2)
5302         it=iabs(itype(i))
5303         if (it.eq.10) goto 1
5304 c
5305 C  Compute the axes of tghe local cartesian coordinates system; store in
5306 c   x_prime, y_prime and z_prime
5307 c
5308         do j=1,3
5309           x_prime(j) = 0.00
5310           y_prime(j) = 0.00
5311           z_prime(j) = 0.00
5312         enddo
5313 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5314 C     &   dc_norm(3,i+nres)
5315         do j = 1,3
5316           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5317           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5318         enddo
5319         do j = 1,3
5320           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5321         enddo
5322 c       write (2,*) "i",i
5323 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5324 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5325 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5326 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5327 c      & " xy",scalar(x_prime(1),y_prime(1)),
5328 c      & " xz",scalar(x_prime(1),z_prime(1)),
5329 c      & " yy",scalar(y_prime(1),y_prime(1)),
5330 c      & " yz",scalar(y_prime(1),z_prime(1)),
5331 c      & " zz",scalar(z_prime(1),z_prime(1))
5332 c
5333 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5334 C to local coordinate system. Store in xx, yy, zz.
5335 c
5336         xx=0.0d0
5337         yy=0.0d0
5338         zz=0.0d0
5339         do j = 1,3
5340           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5341           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5342           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5343         enddo
5344
5345         xxtab(i)=xx
5346         yytab(i)=yy
5347         zztab(i)=zz
5348 C
5349 C Compute the energy of the ith side cbain
5350 C
5351 c        write (2,*) "xx",xx," yy",yy," zz",zz
5352         it=iabs(itype(i))
5353         do j = 1,65
5354           x(j) = sc_parmin(j,it)
5355         enddo
5356 #ifdef CHECK_COORD
5357 Cc diagnostics - remove later
5358         xx1 = dcos(alph(2))
5359         yy1 = dsin(alph(2))*dcos(omeg(2))
5360         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5361         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5362      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5363      &    xx1,yy1,zz1
5364 C,"  --- ", xx_w,yy_w,zz_w
5365 c end diagnostics
5366 #endif
5367         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5368      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5369      &   + x(10)*yy*zz
5370         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5371      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5372      & + x(20)*yy*zz
5373         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5374      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5375      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5376      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5377      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5378      &  +x(40)*xx*yy*zz
5379         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5380      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5381      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5382      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5383      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5384      &  +x(60)*xx*yy*zz
5385         dsc_i   = 0.743d0+x(61)
5386         dp2_i   = 1.9d0+x(62)
5387         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5388      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5389         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5390      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5391         s1=(1+x(63))/(0.1d0 + dscp1)
5392         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5393         s2=(1+x(65))/(0.1d0 + dscp2)
5394         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5395         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5396      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5397 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5398 c     &   sumene4,
5399 c     &   dscp1,dscp2,sumene
5400 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5401         escloc = escloc + sumene
5402 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5403 c     & ,zz,xx,yy
5404 c#define DEBUG
5405 #ifdef DEBUG
5406 C
5407 C This section to check the numerical derivatives of the energy of ith side
5408 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5409 C #define DEBUG in the code to turn it on.
5410 C
5411         write (2,*) "sumene               =",sumene
5412         aincr=1.0d-7
5413         xxsave=xx
5414         xx=xx+aincr
5415         write (2,*) xx,yy,zz
5416         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5417         de_dxx_num=(sumenep-sumene)/aincr
5418         xx=xxsave
5419         write (2,*) "xx+ sumene from enesc=",sumenep
5420         yysave=yy
5421         yy=yy+aincr
5422         write (2,*) xx,yy,zz
5423         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5424         de_dyy_num=(sumenep-sumene)/aincr
5425         yy=yysave
5426         write (2,*) "yy+ sumene from enesc=",sumenep
5427         zzsave=zz
5428         zz=zz+aincr
5429         write (2,*) xx,yy,zz
5430         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5431         de_dzz_num=(sumenep-sumene)/aincr
5432         zz=zzsave
5433         write (2,*) "zz+ sumene from enesc=",sumenep
5434         costsave=cost2tab(i+1)
5435         sintsave=sint2tab(i+1)
5436         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5437         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5438         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5439         de_dt_num=(sumenep-sumene)/aincr
5440         write (2,*) " t+ sumene from enesc=",sumenep
5441         cost2tab(i+1)=costsave
5442         sint2tab(i+1)=sintsave
5443 C End of diagnostics section.
5444 #endif
5445 C
5446 C Compute the gradient of esc
5447 C
5448 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5449         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5450         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5451         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5452         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5453         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5454         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5455         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5456         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5457         pom1=(sumene3*sint2tab(i+1)+sumene1)
5458      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5459         pom2=(sumene4*cost2tab(i+1)+sumene2)
5460      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5461         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5462         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5463      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5464      &  +x(40)*yy*zz
5465         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5466         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5467      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5468      &  +x(60)*yy*zz
5469         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5470      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5471      &        +(pom1+pom2)*pom_dx
5472 #ifdef DEBUG
5473         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5474 #endif
5475 C
5476         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5477         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5478      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5479      &  +x(40)*xx*zz
5480         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5481         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5482      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5483      &  +x(59)*zz**2 +x(60)*xx*zz
5484         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5485      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5486      &        +(pom1-pom2)*pom_dy
5487 #ifdef DEBUG
5488         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5489 #endif
5490 C
5491         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5492      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5493      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5494      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5495      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5496      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5497      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5498      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5499 #ifdef DEBUG
5500         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5501 #endif
5502 C
5503         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5504      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5505      &  +pom1*pom_dt1+pom2*pom_dt2
5506 #ifdef DEBUG
5507         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5508 #endif
5509 c#undef DEBUG
5510 c
5511 C
5512        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5513        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5514        cosfac2xx=cosfac2*xx
5515        sinfac2yy=sinfac2*yy
5516        do k = 1,3
5517          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5518      &      vbld_inv(i+1)
5519          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5520      &      vbld_inv(i)
5521          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5522          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5523 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5524 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5525 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5526 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5527          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5528          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5529          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5530          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5531          dZZ_Ci1(k)=0.0d0
5532          dZZ_Ci(k)=0.0d0
5533          do j=1,3
5534            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5535      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5536            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5537      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5538          enddo
5539
5540          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5541          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5542          dZZ_XYZ(k)=vbld_inv(i+nres)*
5543      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5544 c
5545          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5546          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5547        enddo
5548
5549        do k=1,3
5550          dXX_Ctab(k,i)=dXX_Ci(k)
5551          dXX_C1tab(k,i)=dXX_Ci1(k)
5552          dYY_Ctab(k,i)=dYY_Ci(k)
5553          dYY_C1tab(k,i)=dYY_Ci1(k)
5554          dZZ_Ctab(k,i)=dZZ_Ci(k)
5555          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5556          dXX_XYZtab(k,i)=dXX_XYZ(k)
5557          dYY_XYZtab(k,i)=dYY_XYZ(k)
5558          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5559        enddo
5560
5561        do k = 1,3
5562 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5563 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5564 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5565 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5566 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5567 c     &    dt_dci(k)
5568 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5569 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5570          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5571      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5572          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5573      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5574          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5575      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5576        enddo
5577 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5578 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5579
5580 C to check gradient call subroutine check_grad
5581
5582     1 continue
5583       enddo
5584       return
5585       end
5586 c------------------------------------------------------------------------------
5587       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5588       implicit none
5589       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5590      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5591       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5592      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5593      &   + x(10)*yy*zz
5594       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5595      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5596      & + x(20)*yy*zz
5597       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5598      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5599      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5600      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5601      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5602      &  +x(40)*xx*yy*zz
5603       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5604      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5605      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5606      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5607      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5608      &  +x(60)*xx*yy*zz
5609       dsc_i   = 0.743d0+x(61)
5610       dp2_i   = 1.9d0+x(62)
5611       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5612      &          *(xx*cost2+yy*sint2))
5613       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5614      &          *(xx*cost2-yy*sint2))
5615       s1=(1+x(63))/(0.1d0 + dscp1)
5616       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5617       s2=(1+x(65))/(0.1d0 + dscp2)
5618       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5619       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5620      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5621       enesc=sumene
5622       return
5623       end
5624 #endif
5625 c------------------------------------------------------------------------------
5626       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5627 C
5628 C This procedure calculates two-body contact function g(rij) and its derivative:
5629 C
5630 C           eps0ij                                     !       x < -1
5631 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5632 C            0                                         !       x > 1
5633 C
5634 C where x=(rij-r0ij)/delta
5635 C
5636 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5637 C
5638       implicit none
5639       double precision rij,r0ij,eps0ij,fcont,fprimcont
5640       double precision x,x2,x4,delta
5641 c     delta=0.02D0*r0ij
5642 c      delta=0.2D0*r0ij
5643       x=(rij-r0ij)/delta
5644       if (x.lt.-1.0D0) then
5645         fcont=eps0ij
5646         fprimcont=0.0D0
5647       else if (x.le.1.0D0) then
5648         x2=x*x
5649         x4=x2*x2
5650         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5651         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5652       else
5653         fcont=0.0D0
5654         fprimcont=0.0D0
5655       endif
5656       return
5657       end
5658 c------------------------------------------------------------------------------
5659       subroutine splinthet(theti,delta,ss,ssder)
5660       implicit real*8 (a-h,o-z)
5661       include 'DIMENSIONS'
5662       include 'COMMON.VAR'
5663       include 'COMMON.GEO'
5664       thetup=pi-delta
5665       thetlow=delta
5666       if (theti.gt.pipol) then
5667         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5668       else
5669         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5670         ssder=-ssder
5671       endif
5672       return
5673       end
5674 c------------------------------------------------------------------------------
5675       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5676       implicit none
5677       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5678       double precision ksi,ksi2,ksi3,a1,a2,a3
5679       a1=fprim0*delta/(f1-f0)
5680       a2=3.0d0-2.0d0*a1
5681       a3=a1-2.0d0
5682       ksi=(x-x0)/delta
5683       ksi2=ksi*ksi
5684       ksi3=ksi2*ksi
5685       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5686       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5687       return
5688       end
5689 c------------------------------------------------------------------------------
5690       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5691       implicit none
5692       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5693       double precision ksi,ksi2,ksi3,a1,a2,a3
5694       ksi=(x-x0)/delta
5695       ksi2=ksi*ksi
5696       ksi3=ksi2*ksi
5697       a1=fprim0x*delta
5698       a2=3*(f1x-f0x)-2*fprim0x*delta
5699       a3=fprim0x*delta-2*(f1x-f0x)
5700       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5701       return
5702       end
5703 C-----------------------------------------------------------------------------
5704 #ifdef CRYST_TOR
5705 C-----------------------------------------------------------------------------
5706       subroutine etor(etors,edihcnstr)
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.VAR'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.TORSION'
5713       include 'COMMON.INTERACT'
5714       include 'COMMON.DERIV'
5715       include 'COMMON.CHAIN'
5716       include 'COMMON.NAMES'
5717       include 'COMMON.IOUNITS'
5718       include 'COMMON.FFIELD'
5719       include 'COMMON.TORCNSTR'
5720       include 'COMMON.CONTROL'
5721       logical lprn
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724 c      lprn=.true.
5725       etors=0.0D0
5726       do i=iphi_start,iphi_end
5727       etors_ii=0.0D0
5728         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5729      &      .or. itype(i).eq.ntyp1) cycle
5730         itori=itortyp(itype(i-2))
5731         itori1=itortyp(itype(i-1))
5732         phii=phi(i)
5733         gloci=0.0D0
5734 C Proline-Proline pair is a special case...
5735         if (itori.eq.3 .and. itori1.eq.3) then
5736           if (phii.gt.-dwapi3) then
5737             cosphi=dcos(3*phii)
5738             fac=1.0D0/(1.0D0-cosphi)
5739             etorsi=v1(1,3,3)*fac
5740             etorsi=etorsi+etorsi
5741             etors=etors+etorsi-v1(1,3,3)
5742             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5743             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5744           endif
5745           do j=1,3
5746             v1ij=v1(j+1,itori,itori1)
5747             v2ij=v2(j+1,itori,itori1)
5748             cosphi=dcos(j*phii)
5749             sinphi=dsin(j*phii)
5750             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5751             if (energy_dec) etors_ii=etors_ii+
5752      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5753             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5754           enddo
5755         else
5756           do j=1,nterm_old
5757             v1ij=v1(j,itori,itori1)
5758             v2ij=v2(j,itori,itori1)
5759             cosphi=dcos(j*phii)
5760             sinphi=dsin(j*phii)
5761             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5762             if (energy_dec) etors_ii=etors_ii+
5763      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5764             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5765           enddo
5766         endif
5767         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5768              'etor',i,etors_ii
5769         if (lprn)
5770      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5771      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5772      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5773         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5774 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5775       enddo
5776 ! 6/20/98 - dihedral angle constraints
5777       edihcnstr=0.0d0
5778       do i=1,ndih_constr
5779         itori=idih_constr(i)
5780         phii=phi(itori)
5781         difi=phii-phi0(i)
5782         if (difi.gt.drange(i)) then
5783           difi=difi-drange(i)
5784           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5785           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5786         else if (difi.lt.-drange(i)) then
5787           difi=difi+drange(i)
5788           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5789           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5790         endif
5791 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5792 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5793       enddo
5794 !      write (iout,*) 'edihcnstr',edihcnstr
5795       return
5796       end
5797 c------------------------------------------------------------------------------
5798       subroutine etor_d(etors_d)
5799       etors_d=0.0d0
5800       return
5801       end
5802 c----------------------------------------------------------------------------
5803 #else
5804       subroutine etor(etors,edihcnstr)
5805       implicit real*8 (a-h,o-z)
5806       include 'DIMENSIONS'
5807       include 'COMMON.VAR'
5808       include 'COMMON.GEO'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.TORSION'
5811       include 'COMMON.INTERACT'
5812       include 'COMMON.DERIV'
5813       include 'COMMON.CHAIN'
5814       include 'COMMON.NAMES'
5815       include 'COMMON.IOUNITS'
5816       include 'COMMON.FFIELD'
5817       include 'COMMON.TORCNSTR'
5818       include 'COMMON.CONTROL'
5819       logical lprn
5820 C Set lprn=.true. for debugging
5821       lprn=.false.
5822 c     lprn=.true.
5823       etors=0.0D0
5824       do i=iphi_start,iphi_end
5825         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5826      &       .or. itype(i).eq.ntyp1) cycle
5827         etors_ii=0.0D0
5828          if (iabs(itype(i)).eq.20) then
5829          iblock=2
5830          else
5831          iblock=1
5832          endif
5833         itori=itortyp(itype(i-2))
5834         itori1=itortyp(itype(i-1))
5835         phii=phi(i)
5836         gloci=0.0D0
5837 C Regular cosine and sine terms
5838         do j=1,nterm(itori,itori1,iblock)
5839           v1ij=v1(j,itori,itori1,iblock)
5840           v2ij=v2(j,itori,itori1,iblock)
5841           cosphi=dcos(j*phii)
5842           sinphi=dsin(j*phii)
5843           etors=etors+v1ij*cosphi+v2ij*sinphi
5844           if (energy_dec) etors_ii=etors_ii+
5845      &                v1ij*cosphi+v2ij*sinphi
5846           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5847         enddo
5848 C Lorentz terms
5849 C                         v1
5850 C  E = SUM ----------------------------------- - v1
5851 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5852 C
5853         cosphi=dcos(0.5d0*phii)
5854         sinphi=dsin(0.5d0*phii)
5855         do j=1,nlor(itori,itori1,iblock)
5856           vl1ij=vlor1(j,itori,itori1)
5857           vl2ij=vlor2(j,itori,itori1)
5858           vl3ij=vlor3(j,itori,itori1)
5859           pom=vl2ij*cosphi+vl3ij*sinphi
5860           pom1=1.0d0/(pom*pom+1.0d0)
5861           etors=etors+vl1ij*pom1
5862           if (energy_dec) etors_ii=etors_ii+
5863      &                vl1ij*pom1
5864           pom=-pom*pom1*pom1
5865           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5866         enddo
5867 C Subtract the constant term
5868         etors=etors-v0(itori,itori1,iblock)
5869           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5870      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5871         if (lprn)
5872      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5873      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5874      &  (v1(j,itori,itori1,iblock),j=1,6),
5875      &  (v2(j,itori,itori1,iblock),j=1,6)
5876         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5877 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5878       enddo
5879 ! 6/20/98 - dihedral angle constraints
5880       edihcnstr=0.0d0
5881 c      do i=1,ndih_constr
5882       do i=idihconstr_start,idihconstr_end
5883         itori=idih_constr(i)
5884         phii=phi(itori)
5885         difi=pinorm(phii-phi0(i))
5886         if (difi.gt.drange(i)) then
5887           difi=difi-drange(i)
5888           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5889           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5890         else if (difi.lt.-drange(i)) then
5891           difi=difi+drange(i)
5892           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5893           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5894         else
5895           difi=0.0
5896         endif
5897 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5898 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5899 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5900       enddo
5901 cd       write (iout,*) 'edihcnstr',edihcnstr
5902       return
5903       end
5904 c----------------------------------------------------------------------------
5905       subroutine etor_d(etors_d)
5906 C 6/23/01 Compute double torsional energy
5907       implicit real*8 (a-h,o-z)
5908       include 'DIMENSIONS'
5909       include 'COMMON.VAR'
5910       include 'COMMON.GEO'
5911       include 'COMMON.LOCAL'
5912       include 'COMMON.TORSION'
5913       include 'COMMON.INTERACT'
5914       include 'COMMON.DERIV'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.NAMES'
5917       include 'COMMON.IOUNITS'
5918       include 'COMMON.FFIELD'
5919       include 'COMMON.TORCNSTR'
5920       logical lprn
5921 C Set lprn=.true. for debugging
5922       lprn=.false.
5923 c     lprn=.true.
5924       etors_d=0.0D0
5925 c      write(iout,*) "a tu??"
5926       do i=iphid_start,iphid_end
5927         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5928      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5929         itori=itortyp(itype(i-2))
5930         itori1=itortyp(itype(i-1))
5931         itori2=itortyp(itype(i))
5932         phii=phi(i)
5933         phii1=phi(i+1)
5934         gloci1=0.0D0
5935         gloci2=0.0D0
5936         iblock=1
5937         if (iabs(itype(i+1)).eq.20) iblock=2
5938
5939 C Regular cosine and sine terms
5940         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5941           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5942           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5943           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5944           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5945           cosphi1=dcos(j*phii)
5946           sinphi1=dsin(j*phii)
5947           cosphi2=dcos(j*phii1)
5948           sinphi2=dsin(j*phii1)
5949           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5950      &     v2cij*cosphi2+v2sij*sinphi2
5951           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5952           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5953         enddo
5954         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5955           do l=1,k-1
5956             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5957             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5958             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5959             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5960             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5961             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5962             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5963             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5964             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5965      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5966             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5967      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5968             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5969      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5970           enddo
5971         enddo
5972         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5973         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5974       enddo
5975       return
5976       end
5977 #endif
5978 c------------------------------------------------------------------------------
5979       subroutine eback_sc_corr(esccor)
5980 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5981 c        conformational states; temporarily implemented as differences
5982 c        between UNRES torsional potentials (dependent on three types of
5983 c        residues) and the torsional potentials dependent on all 20 types
5984 c        of residues computed from AM1  energy surfaces of terminally-blocked
5985 c        amino-acid residues.
5986       implicit real*8 (a-h,o-z)
5987       include 'DIMENSIONS'
5988       include 'COMMON.VAR'
5989       include 'COMMON.GEO'
5990       include 'COMMON.LOCAL'
5991       include 'COMMON.TORSION'
5992       include 'COMMON.SCCOR'
5993       include 'COMMON.INTERACT'
5994       include 'COMMON.DERIV'
5995       include 'COMMON.CHAIN'
5996       include 'COMMON.NAMES'
5997       include 'COMMON.IOUNITS'
5998       include 'COMMON.FFIELD'
5999       include 'COMMON.CONTROL'
6000       logical lprn
6001 C Set lprn=.true. for debugging
6002       lprn=.false.
6003 c      lprn=.true.
6004 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6005       esccor=0.0D0
6006       do i=itau_start,itau_end
6007         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6008         esccor_ii=0.0D0
6009         isccori=isccortyp(itype(i-2))
6010         isccori1=isccortyp(itype(i-1))
6011 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6012         phii=phi(i)
6013         do intertyp=1,3 !intertyp
6014 cc Added 09 May 2012 (Adasko)
6015 cc  Intertyp means interaction type of backbone mainchain correlation:
6016 c   1 = SC...Ca...Ca...Ca
6017 c   2 = Ca...Ca...Ca...SC
6018 c   3 = SC...Ca...Ca...SCi
6019         gloci=0.0D0
6020         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6021      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6022      &      (itype(i-1).eq.ntyp1)))
6023      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6024      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6025      &     .or.(itype(i).eq.ntyp1)))
6026      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6027      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6028      &      (itype(i-3).eq.ntyp1)))) cycle
6029         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6030         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6031      & cycle
6032        do j=1,nterm_sccor(isccori,isccori1)
6033           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6034           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6035           cosphi=dcos(j*tauangle(intertyp,i))
6036           sinphi=dsin(j*tauangle(intertyp,i))
6037           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6038           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6039         enddo
6040 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6041         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6042         if (lprn)
6043      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6044      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6045      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6046      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6047         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6048        enddo !intertyp
6049       enddo
6050
6051       return
6052       end
6053 c----------------------------------------------------------------------------
6054       subroutine multibody(ecorr)
6055 C This subroutine calculates multi-body contributions to energy following
6056 C the idea of Skolnick et al. If side chains I and J make a contact and
6057 C at the same time side chains I+1 and J+1 make a contact, an extra
6058 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6059       implicit real*8 (a-h,o-z)
6060       include 'DIMENSIONS'
6061       include 'COMMON.IOUNITS'
6062       include 'COMMON.DERIV'
6063       include 'COMMON.INTERACT'
6064       include 'COMMON.CONTACTS'
6065       double precision gx(3),gx1(3)
6066       logical lprn
6067
6068 C Set lprn=.true. for debugging
6069       lprn=.false.
6070
6071       if (lprn) then
6072         write (iout,'(a)') 'Contact function values:'
6073         do i=nnt,nct-2
6074           write (iout,'(i2,20(1x,i2,f10.5))')
6075      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6076         enddo
6077       endif
6078       ecorr=0.0D0
6079       do i=nnt,nct
6080         do j=1,3
6081           gradcorr(j,i)=0.0D0
6082           gradxorr(j,i)=0.0D0
6083         enddo
6084       enddo
6085       do i=nnt,nct-2
6086
6087         DO ISHIFT = 3,4
6088
6089         i1=i+ishift
6090         num_conti=num_cont(i)
6091         num_conti1=num_cont(i1)
6092         do jj=1,num_conti
6093           j=jcont(jj,i)
6094           do kk=1,num_conti1
6095             j1=jcont(kk,i1)
6096             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6097 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6098 cd   &                   ' ishift=',ishift
6099 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6100 C The system gains extra energy.
6101               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6102             endif   ! j1==j+-ishift
6103           enddo     ! kk
6104         enddo       ! jj
6105
6106         ENDDO ! ISHIFT
6107
6108       enddo         ! i
6109       return
6110       end
6111 c------------------------------------------------------------------------------
6112       double precision function esccorr(i,j,k,l,jj,kk)
6113       implicit real*8 (a-h,o-z)
6114       include 'DIMENSIONS'
6115       include 'COMMON.IOUNITS'
6116       include 'COMMON.DERIV'
6117       include 'COMMON.INTERACT'
6118       include 'COMMON.CONTACTS'
6119       double precision gx(3),gx1(3)
6120       logical lprn
6121       lprn=.false.
6122       eij=facont(jj,i)
6123       ekl=facont(kk,k)
6124 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6125 C Calculate the multi-body contribution to energy.
6126 C Calculate multi-body contributions to the gradient.
6127 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6128 cd   & k,l,(gacont(m,kk,k),m=1,3)
6129       do m=1,3
6130         gx(m) =ekl*gacont(m,jj,i)
6131         gx1(m)=eij*gacont(m,kk,k)
6132         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6133         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6134         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6135         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6136       enddo
6137       do m=i,j-1
6138         do ll=1,3
6139           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6140         enddo
6141       enddo
6142       do m=k,l-1
6143         do ll=1,3
6144           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6145         enddo
6146       enddo
6147       esccorr=-eij*ekl
6148       return
6149       end
6150 c------------------------------------------------------------------------------
6151       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6152 C This subroutine calculates multi-body contributions to hydrogen-bonding
6153       implicit real*8 (a-h,o-z)
6154       include 'DIMENSIONS'
6155       include 'COMMON.IOUNITS'
6156 #ifdef MPI
6157       include "mpif.h"
6158       parameter (max_cont=maxconts)
6159       parameter (max_dim=26)
6160       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6161       double precision zapas(max_dim,maxconts,max_fg_procs),
6162      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6163       common /przechowalnia/ zapas
6164       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6165      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6166 #endif
6167       include 'COMMON.SETUP'
6168       include 'COMMON.FFIELD'
6169       include 'COMMON.DERIV'
6170       include 'COMMON.INTERACT'
6171       include 'COMMON.CONTACTS'
6172       include 'COMMON.CONTROL'
6173       include 'COMMON.LOCAL'
6174       double precision gx(3),gx1(3),time00
6175       logical lprn,ldone
6176
6177 C Set lprn=.true. for debugging
6178       lprn=.false.
6179 #ifdef MPI
6180       n_corr=0
6181       n_corr1=0
6182       if (nfgtasks.le.1) goto 30
6183       if (lprn) then
6184         write (iout,'(a)') 'Contact function values before RECEIVE:'
6185         do i=nnt,nct-2
6186           write (iout,'(2i3,50(1x,i2,f5.2))')
6187      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6188      &    j=1,num_cont_hb(i))
6189         enddo
6190       endif
6191       call flush(iout)
6192       do i=1,ntask_cont_from
6193         ncont_recv(i)=0
6194       enddo
6195       do i=1,ntask_cont_to
6196         ncont_sent(i)=0
6197       enddo
6198 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6199 c     & ntask_cont_to
6200 C Make the list of contacts to send to send to other procesors
6201 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6202 c      call flush(iout)
6203       do i=iturn3_start,iturn3_end
6204 c        write (iout,*) "make contact list turn3",i," num_cont",
6205 c     &    num_cont_hb(i)
6206         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6207       enddo
6208       do i=iturn4_start,iturn4_end
6209 c        write (iout,*) "make contact list turn4",i," num_cont",
6210 c     &   num_cont_hb(i)
6211         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6212       enddo
6213       do ii=1,nat_sent
6214         i=iat_sent(ii)
6215 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6216 c     &    num_cont_hb(i)
6217         do j=1,num_cont_hb(i)
6218         do k=1,4
6219           jjc=jcont_hb(j,i)
6220           iproc=iint_sent_local(k,jjc,ii)
6221 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6222           if (iproc.gt.0) then
6223             ncont_sent(iproc)=ncont_sent(iproc)+1
6224             nn=ncont_sent(iproc)
6225             zapas(1,nn,iproc)=i
6226             zapas(2,nn,iproc)=jjc
6227             zapas(3,nn,iproc)=facont_hb(j,i)
6228             zapas(4,nn,iproc)=ees0p(j,i)
6229             zapas(5,nn,iproc)=ees0m(j,i)
6230             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6231             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6232             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6233             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6234             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6235             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6236             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6237             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6238             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6239             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6240             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6241             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6242             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6243             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6244             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6245             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6246             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6247             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6248             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6249             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6250             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6251           endif
6252         enddo
6253         enddo
6254       enddo
6255       if (lprn) then
6256       write (iout,*)
6257      &  "Numbers of contacts to be sent to other processors",
6258      &  (ncont_sent(i),i=1,ntask_cont_to)
6259       write (iout,*) "Contacts sent"
6260       do ii=1,ntask_cont_to
6261         nn=ncont_sent(ii)
6262         iproc=itask_cont_to(ii)
6263         write (iout,*) nn," contacts to processor",iproc,
6264      &   " of CONT_TO_COMM group"
6265         do i=1,nn
6266           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6267         enddo
6268       enddo
6269       call flush(iout)
6270       endif
6271       CorrelType=477
6272       CorrelID=fg_rank+1
6273       CorrelType1=478
6274       CorrelID1=nfgtasks+fg_rank+1
6275       ireq=0
6276 C Receive the numbers of needed contacts from other processors
6277       do ii=1,ntask_cont_from
6278         iproc=itask_cont_from(ii)
6279         ireq=ireq+1
6280         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6281      &    FG_COMM,req(ireq),IERR)
6282       enddo
6283 c      write (iout,*) "IRECV ended"
6284 c      call flush(iout)
6285 C Send the number of contacts needed by other processors
6286       do ii=1,ntask_cont_to
6287         iproc=itask_cont_to(ii)
6288         ireq=ireq+1
6289         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6290      &    FG_COMM,req(ireq),IERR)
6291       enddo
6292 c      write (iout,*) "ISEND ended"
6293 c      write (iout,*) "number of requests (nn)",ireq
6294       call flush(iout)
6295       if (ireq.gt.0)
6296      &  call MPI_Waitall(ireq,req,status_array,ierr)
6297 c      write (iout,*)
6298 c     &  "Numbers of contacts to be received from other processors",
6299 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6300 c      call flush(iout)
6301 C Receive contacts
6302       ireq=0
6303       do ii=1,ntask_cont_from
6304         iproc=itask_cont_from(ii)
6305         nn=ncont_recv(ii)
6306 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6307 c     &   " of CONT_TO_COMM group"
6308         call flush(iout)
6309         if (nn.gt.0) then
6310           ireq=ireq+1
6311           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6312      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6313 c          write (iout,*) "ireq,req",ireq,req(ireq)
6314         endif
6315       enddo
6316 C Send the contacts to processors that need them
6317       do ii=1,ntask_cont_to
6318         iproc=itask_cont_to(ii)
6319         nn=ncont_sent(ii)
6320 c        write (iout,*) nn," contacts to processor",iproc,
6321 c     &   " of CONT_TO_COMM group"
6322         if (nn.gt.0) then
6323           ireq=ireq+1
6324           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6325      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6326 c          write (iout,*) "ireq,req",ireq,req(ireq)
6327 c          do i=1,nn
6328 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6329 c          enddo
6330         endif
6331       enddo
6332 c      write (iout,*) "number of requests (contacts)",ireq
6333 c      write (iout,*) "req",(req(i),i=1,4)
6334 c      call flush(iout)
6335       if (ireq.gt.0)
6336      & call MPI_Waitall(ireq,req,status_array,ierr)
6337       do iii=1,ntask_cont_from
6338         iproc=itask_cont_from(iii)
6339         nn=ncont_recv(iii)
6340         if (lprn) then
6341         write (iout,*) "Received",nn," contacts from processor",iproc,
6342      &   " of CONT_FROM_COMM group"
6343         call flush(iout)
6344         do i=1,nn
6345           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6346         enddo
6347         call flush(iout)
6348         endif
6349         do i=1,nn
6350           ii=zapas_recv(1,i,iii)
6351 c Flag the received contacts to prevent double-counting
6352           jj=-zapas_recv(2,i,iii)
6353 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6354 c          call flush(iout)
6355           nnn=num_cont_hb(ii)+1
6356           num_cont_hb(ii)=nnn
6357           jcont_hb(nnn,ii)=jj
6358           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6359           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6360           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6361           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6362           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6363           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6364           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6365           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6366           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6367           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6368           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6369           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6370           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6371           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6372           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6373           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6374           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6375           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6376           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6377           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6378           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6379           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6380           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6381           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6382         enddo
6383       enddo
6384       call flush(iout)
6385       if (lprn) then
6386         write (iout,'(a)') 'Contact function values after receive:'
6387         do i=nnt,nct-2
6388           write (iout,'(2i3,50(1x,i3,f5.2))')
6389      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6390      &    j=1,num_cont_hb(i))
6391         enddo
6392         call flush(iout)
6393       endif
6394    30 continue
6395 #endif
6396       if (lprn) then
6397         write (iout,'(a)') 'Contact function values:'
6398         do i=nnt,nct-2
6399           write (iout,'(2i3,50(1x,i3,f5.2))')
6400      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6401      &    j=1,num_cont_hb(i))
6402         enddo
6403       endif
6404       ecorr=0.0D0
6405 C Remove the loop below after debugging !!!
6406       do i=nnt,nct
6407         do j=1,3
6408           gradcorr(j,i)=0.0D0
6409           gradxorr(j,i)=0.0D0
6410         enddo
6411       enddo
6412 C Calculate the local-electrostatic correlation terms
6413       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6414         i1=i+1
6415         num_conti=num_cont_hb(i)
6416         num_conti1=num_cont_hb(i+1)
6417         do jj=1,num_conti
6418           j=jcont_hb(jj,i)
6419           jp=iabs(j)
6420           do kk=1,num_conti1
6421             j1=jcont_hb(kk,i1)
6422             jp1=iabs(j1)
6423 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6424 c     &         ' jj=',jj,' kk=',kk
6425             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6426      &          .or. j.lt.0 .and. j1.gt.0) .and.
6427      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6428 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6429 C The system gains extra energy.
6430               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6431               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6432      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6433               n_corr=n_corr+1
6434             else if (j1.eq.j) then
6435 C Contacts I-J and I-(J+1) occur simultaneously.
6436 C The system loses extra energy.
6437 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6438             endif
6439           enddo ! kk
6440           do kk=1,num_conti
6441             j1=jcont_hb(kk,i)
6442 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6443 c    &         ' jj=',jj,' kk=',kk
6444             if (j1.eq.j+1) then
6445 C Contacts I-J and (I+1)-J occur simultaneously.
6446 C The system loses extra energy.
6447 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6448             endif ! j1==j+1
6449           enddo ! kk
6450         enddo ! jj
6451       enddo ! i
6452       return
6453       end
6454 c------------------------------------------------------------------------------
6455       subroutine add_hb_contact(ii,jj,itask)
6456       implicit real*8 (a-h,o-z)
6457       include "DIMENSIONS"
6458       include "COMMON.IOUNITS"
6459       integer max_cont
6460       integer max_dim
6461       parameter (max_cont=maxconts)
6462       parameter (max_dim=26)
6463       include "COMMON.CONTACTS"
6464       double precision zapas(max_dim,maxconts,max_fg_procs),
6465      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6466       common /przechowalnia/ zapas
6467       integer i,j,ii,jj,iproc,itask(4),nn
6468 c      write (iout,*) "itask",itask
6469       do i=1,2
6470         iproc=itask(i)
6471         if (iproc.gt.0) then
6472           do j=1,num_cont_hb(ii)
6473             jjc=jcont_hb(j,ii)
6474 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6475             if (jjc.eq.jj) then
6476               ncont_sent(iproc)=ncont_sent(iproc)+1
6477               nn=ncont_sent(iproc)
6478               zapas(1,nn,iproc)=ii
6479               zapas(2,nn,iproc)=jjc
6480               zapas(3,nn,iproc)=facont_hb(j,ii)
6481               zapas(4,nn,iproc)=ees0p(j,ii)
6482               zapas(5,nn,iproc)=ees0m(j,ii)
6483               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6484               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6485               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6486               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6487               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6488               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6489               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6490               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6491               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6492               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6493               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6494               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6495               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6496               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6497               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6498               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6499               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6500               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6501               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6502               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6503               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6504               exit
6505             endif
6506           enddo
6507         endif
6508       enddo
6509       return
6510       end
6511 c------------------------------------------------------------------------------
6512       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6513      &  n_corr1)
6514 C This subroutine calculates multi-body contributions to hydrogen-bonding
6515       implicit real*8 (a-h,o-z)
6516       include 'DIMENSIONS'
6517       include 'COMMON.IOUNITS'
6518 #ifdef MPI
6519       include "mpif.h"
6520       parameter (max_cont=maxconts)
6521       parameter (max_dim=70)
6522       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6523       double precision zapas(max_dim,maxconts,max_fg_procs),
6524      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6525       common /przechowalnia/ zapas
6526       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6527      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6528 #endif
6529       include 'COMMON.SETUP'
6530       include 'COMMON.FFIELD'
6531       include 'COMMON.DERIV'
6532       include 'COMMON.LOCAL'
6533       include 'COMMON.INTERACT'
6534       include 'COMMON.CONTACTS'
6535       include 'COMMON.CHAIN'
6536       include 'COMMON.CONTROL'
6537       double precision gx(3),gx1(3)
6538       integer num_cont_hb_old(maxres)
6539       logical lprn,ldone
6540       double precision eello4,eello5,eelo6,eello_turn6
6541       external eello4,eello5,eello6,eello_turn6
6542 C Set lprn=.true. for debugging
6543       lprn=.false.
6544       eturn6=0.0d0
6545 #ifdef MPI
6546       do i=1,nres
6547         num_cont_hb_old(i)=num_cont_hb(i)
6548       enddo
6549       n_corr=0
6550       n_corr1=0
6551       if (nfgtasks.le.1) goto 30
6552       if (lprn) then
6553         write (iout,'(a)') 'Contact function values before RECEIVE:'
6554         do i=nnt,nct-2
6555           write (iout,'(2i3,50(1x,i2,f5.2))')
6556      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6557      &    j=1,num_cont_hb(i))
6558         enddo
6559       endif
6560       call flush(iout)
6561       do i=1,ntask_cont_from
6562         ncont_recv(i)=0
6563       enddo
6564       do i=1,ntask_cont_to
6565         ncont_sent(i)=0
6566       enddo
6567 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6568 c     & ntask_cont_to
6569 C Make the list of contacts to send to send to other procesors
6570       do i=iturn3_start,iturn3_end
6571 c        write (iout,*) "make contact list turn3",i," num_cont",
6572 c     &    num_cont_hb(i)
6573         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6574       enddo
6575       do i=iturn4_start,iturn4_end
6576 c        write (iout,*) "make contact list turn4",i," num_cont",
6577 c     &   num_cont_hb(i)
6578         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6579       enddo
6580       do ii=1,nat_sent
6581         i=iat_sent(ii)
6582 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6583 c     &    num_cont_hb(i)
6584         do j=1,num_cont_hb(i)
6585         do k=1,4
6586           jjc=jcont_hb(j,i)
6587           iproc=iint_sent_local(k,jjc,ii)
6588 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6589           if (iproc.ne.0) then
6590             ncont_sent(iproc)=ncont_sent(iproc)+1
6591             nn=ncont_sent(iproc)
6592             zapas(1,nn,iproc)=i
6593             zapas(2,nn,iproc)=jjc
6594             zapas(3,nn,iproc)=d_cont(j,i)
6595             ind=3
6596             do kk=1,3
6597               ind=ind+1
6598               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6599             enddo
6600             do kk=1,2
6601               do ll=1,2
6602                 ind=ind+1
6603                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6604               enddo
6605             enddo
6606             do jj=1,5
6607               do kk=1,3
6608                 do ll=1,2
6609                   do mm=1,2
6610                     ind=ind+1
6611                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6612                   enddo
6613                 enddo
6614               enddo
6615             enddo
6616           endif
6617         enddo
6618         enddo
6619       enddo
6620       if (lprn) then
6621       write (iout,*)
6622      &  "Numbers of contacts to be sent to other processors",
6623      &  (ncont_sent(i),i=1,ntask_cont_to)
6624       write (iout,*) "Contacts sent"
6625       do ii=1,ntask_cont_to
6626         nn=ncont_sent(ii)
6627         iproc=itask_cont_to(ii)
6628         write (iout,*) nn," contacts to processor",iproc,
6629      &   " of CONT_TO_COMM group"
6630         do i=1,nn
6631           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6632         enddo
6633       enddo
6634       call flush(iout)
6635       endif
6636       CorrelType=477
6637       CorrelID=fg_rank+1
6638       CorrelType1=478
6639       CorrelID1=nfgtasks+fg_rank+1
6640       ireq=0
6641 C Receive the numbers of needed contacts from other processors
6642       do ii=1,ntask_cont_from
6643         iproc=itask_cont_from(ii)
6644         ireq=ireq+1
6645         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6646      &    FG_COMM,req(ireq),IERR)
6647       enddo
6648 c      write (iout,*) "IRECV ended"
6649 c      call flush(iout)
6650 C Send the number of contacts needed by other processors
6651       do ii=1,ntask_cont_to
6652         iproc=itask_cont_to(ii)
6653         ireq=ireq+1
6654         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6655      &    FG_COMM,req(ireq),IERR)
6656       enddo
6657 c      write (iout,*) "ISEND ended"
6658 c      write (iout,*) "number of requests (nn)",ireq
6659       call flush(iout)
6660       if (ireq.gt.0)
6661      &  call MPI_Waitall(ireq,req,status_array,ierr)
6662 c      write (iout,*)
6663 c     &  "Numbers of contacts to be received from other processors",
6664 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6665 c      call flush(iout)
6666 C Receive contacts
6667       ireq=0
6668       do ii=1,ntask_cont_from
6669         iproc=itask_cont_from(ii)
6670         nn=ncont_recv(ii)
6671 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6672 c     &   " of CONT_TO_COMM group"
6673         call flush(iout)
6674         if (nn.gt.0) then
6675           ireq=ireq+1
6676           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6677      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6678 c          write (iout,*) "ireq,req",ireq,req(ireq)
6679         endif
6680       enddo
6681 C Send the contacts to processors that need them
6682       do ii=1,ntask_cont_to
6683         iproc=itask_cont_to(ii)
6684         nn=ncont_sent(ii)
6685 c        write (iout,*) nn," contacts to processor",iproc,
6686 c     &   " of CONT_TO_COMM group"
6687         if (nn.gt.0) then
6688           ireq=ireq+1
6689           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6690      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6691 c          write (iout,*) "ireq,req",ireq,req(ireq)
6692 c          do i=1,nn
6693 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6694 c          enddo
6695         endif
6696       enddo
6697 c      write (iout,*) "number of requests (contacts)",ireq
6698 c      write (iout,*) "req",(req(i),i=1,4)
6699 c      call flush(iout)
6700       if (ireq.gt.0)
6701      & call MPI_Waitall(ireq,req,status_array,ierr)
6702       do iii=1,ntask_cont_from
6703         iproc=itask_cont_from(iii)
6704         nn=ncont_recv(iii)
6705         if (lprn) then
6706         write (iout,*) "Received",nn," contacts from processor",iproc,
6707      &   " of CONT_FROM_COMM group"
6708         call flush(iout)
6709         do i=1,nn
6710           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6711         enddo
6712         call flush(iout)
6713         endif
6714         do i=1,nn
6715           ii=zapas_recv(1,i,iii)
6716 c Flag the received contacts to prevent double-counting
6717           jj=-zapas_recv(2,i,iii)
6718 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6719 c          call flush(iout)
6720           nnn=num_cont_hb(ii)+1
6721           num_cont_hb(ii)=nnn
6722           jcont_hb(nnn,ii)=jj
6723           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6724           ind=3
6725           do kk=1,3
6726             ind=ind+1
6727             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6728           enddo
6729           do kk=1,2
6730             do ll=1,2
6731               ind=ind+1
6732               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6733             enddo
6734           enddo
6735           do jj=1,5
6736             do kk=1,3
6737               do ll=1,2
6738                 do mm=1,2
6739                   ind=ind+1
6740                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6741                 enddo
6742               enddo
6743             enddo
6744           enddo
6745         enddo
6746       enddo
6747       call flush(iout)
6748       if (lprn) then
6749         write (iout,'(a)') 'Contact function values after receive:'
6750         do i=nnt,nct-2
6751           write (iout,'(2i3,50(1x,i3,5f6.3))')
6752      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6753      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6754         enddo
6755         call flush(iout)
6756       endif
6757    30 continue
6758 #endif
6759       if (lprn) then
6760         write (iout,'(a)') 'Contact function values:'
6761         do i=nnt,nct-2
6762           write (iout,'(2i3,50(1x,i2,5f6.3))')
6763      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6764      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6765         enddo
6766       endif
6767       ecorr=0.0D0
6768       ecorr5=0.0d0
6769       ecorr6=0.0d0
6770 C Remove the loop below after debugging !!!
6771       do i=nnt,nct
6772         do j=1,3
6773           gradcorr(j,i)=0.0D0
6774           gradxorr(j,i)=0.0D0
6775         enddo
6776       enddo
6777 C Calculate the dipole-dipole interaction energies
6778       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6779       do i=iatel_s,iatel_e+1
6780         num_conti=num_cont_hb(i)
6781         do jj=1,num_conti
6782           j=jcont_hb(jj,i)
6783 #ifdef MOMENT
6784           call dipole(i,j,jj)
6785 #endif
6786         enddo
6787       enddo
6788       endif
6789 C Calculate the local-electrostatic correlation terms
6790 c                write (iout,*) "gradcorr5 in eello5 before loop"
6791 c                do iii=1,nres
6792 c                  write (iout,'(i5,3f10.5)')
6793 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6794 c                enddo
6795       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6796 c        write (iout,*) "corr loop i",i
6797         i1=i+1
6798         num_conti=num_cont_hb(i)
6799         num_conti1=num_cont_hb(i+1)
6800         do jj=1,num_conti
6801           j=jcont_hb(jj,i)
6802           jp=iabs(j)
6803           do kk=1,num_conti1
6804             j1=jcont_hb(kk,i1)
6805             jp1=iabs(j1)
6806 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6807 c     &         ' jj=',jj,' kk=',kk
6808 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6809             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6810      &          .or. j.lt.0 .and. j1.gt.0) .and.
6811      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6812 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6813 C The system gains extra energy.
6814               n_corr=n_corr+1
6815               sqd1=dsqrt(d_cont(jj,i))
6816               sqd2=dsqrt(d_cont(kk,i1))
6817               sred_geom = sqd1*sqd2
6818               IF (sred_geom.lt.cutoff_corr) THEN
6819                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6820      &            ekont,fprimcont)
6821 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6822 cd     &         ' jj=',jj,' kk=',kk
6823                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6824                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6825                 do l=1,3
6826                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6827                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6828                 enddo
6829                 n_corr1=n_corr1+1
6830 cd               write (iout,*) 'sred_geom=',sred_geom,
6831 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6832 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6833 cd               write (iout,*) "g_contij",g_contij
6834 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6835 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6836                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6837                 if (wcorr4.gt.0.0d0)
6838      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6839                   if (energy_dec.and.wcorr4.gt.0.0d0)
6840      1                 write (iout,'(a6,4i5,0pf7.3)')
6841      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6842 c                write (iout,*) "gradcorr5 before eello5"
6843 c                do iii=1,nres
6844 c                  write (iout,'(i5,3f10.5)')
6845 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6846 c                enddo
6847                 if (wcorr5.gt.0.0d0)
6848      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6849 c                write (iout,*) "gradcorr5 after eello5"
6850 c                do iii=1,nres
6851 c                  write (iout,'(i5,3f10.5)')
6852 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6853 c                enddo
6854                   if (energy_dec.and.wcorr5.gt.0.0d0)
6855      1                 write (iout,'(a6,4i5,0pf7.3)')
6856      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6857 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6858 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6859                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6860      &               .or. wturn6.eq.0.0d0))then
6861 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6862                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6863                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6864      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6865 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6866 cd     &            'ecorr6=',ecorr6
6867 cd                write (iout,'(4e15.5)') sred_geom,
6868 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6869 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6870 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6871                 else if (wturn6.gt.0.0d0
6872      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6873 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6874                   eturn6=eturn6+eello_turn6(i,jj,kk)
6875                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6876      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6877 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6878                 endif
6879               ENDIF
6880 1111          continue
6881             endif
6882           enddo ! kk
6883         enddo ! jj
6884       enddo ! i
6885       do i=1,nres
6886         num_cont_hb(i)=num_cont_hb_old(i)
6887       enddo
6888 c                write (iout,*) "gradcorr5 in eello5"
6889 c                do iii=1,nres
6890 c                  write (iout,'(i5,3f10.5)')
6891 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6892 c                enddo
6893       return
6894       end
6895 c------------------------------------------------------------------------------
6896       subroutine add_hb_contact_eello(ii,jj,itask)
6897       implicit real*8 (a-h,o-z)
6898       include "DIMENSIONS"
6899       include "COMMON.IOUNITS"
6900       integer max_cont
6901       integer max_dim
6902       parameter (max_cont=maxconts)
6903       parameter (max_dim=70)
6904       include "COMMON.CONTACTS"
6905       double precision zapas(max_dim,maxconts,max_fg_procs),
6906      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6907       common /przechowalnia/ zapas
6908       integer i,j,ii,jj,iproc,itask(4),nn
6909 c      write (iout,*) "itask",itask
6910       do i=1,2
6911         iproc=itask(i)
6912         if (iproc.gt.0) then
6913           do j=1,num_cont_hb(ii)
6914             jjc=jcont_hb(j,ii)
6915 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6916             if (jjc.eq.jj) then
6917               ncont_sent(iproc)=ncont_sent(iproc)+1
6918               nn=ncont_sent(iproc)
6919               zapas(1,nn,iproc)=ii
6920               zapas(2,nn,iproc)=jjc
6921               zapas(3,nn,iproc)=d_cont(j,ii)
6922               ind=3
6923               do kk=1,3
6924                 ind=ind+1
6925                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6926               enddo
6927               do kk=1,2
6928                 do ll=1,2
6929                   ind=ind+1
6930                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6931                 enddo
6932               enddo
6933               do jj=1,5
6934                 do kk=1,3
6935                   do ll=1,2
6936                     do mm=1,2
6937                       ind=ind+1
6938                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6939                     enddo
6940                   enddo
6941                 enddo
6942               enddo
6943               exit
6944             endif
6945           enddo
6946         endif
6947       enddo
6948       return
6949       end
6950 c------------------------------------------------------------------------------
6951       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6952       implicit real*8 (a-h,o-z)
6953       include 'DIMENSIONS'
6954       include 'COMMON.IOUNITS'
6955       include 'COMMON.DERIV'
6956       include 'COMMON.INTERACT'
6957       include 'COMMON.CONTACTS'
6958       double precision gx(3),gx1(3)
6959       logical lprn
6960       lprn=.false.
6961       eij=facont_hb(jj,i)
6962       ekl=facont_hb(kk,k)
6963       ees0pij=ees0p(jj,i)
6964       ees0pkl=ees0p(kk,k)
6965       ees0mij=ees0m(jj,i)
6966       ees0mkl=ees0m(kk,k)
6967       ekont=eij*ekl
6968       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6969 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6970 C Following 4 lines for diagnostics.
6971 cd    ees0pkl=0.0D0
6972 cd    ees0pij=1.0D0
6973 cd    ees0mkl=0.0D0
6974 cd    ees0mij=1.0D0
6975 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6976 c     & 'Contacts ',i,j,
6977 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6978 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6979 c     & 'gradcorr_long'
6980 C Calculate the multi-body contribution to energy.
6981 c      ecorr=ecorr+ekont*ees
6982 C Calculate multi-body contributions to the gradient.
6983       coeffpees0pij=coeffp*ees0pij
6984       coeffmees0mij=coeffm*ees0mij
6985       coeffpees0pkl=coeffp*ees0pkl
6986       coeffmees0mkl=coeffm*ees0mkl
6987       do ll=1,3
6988 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6989         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6990      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6991      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6992         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6993      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6994      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6995 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6996         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6997      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6998      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6999         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7000      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7001      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7002         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7003      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7004      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7005         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7006         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7007         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7008      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7009      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7010         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7011         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7012 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7013       enddo
7014 c      write (iout,*)
7015 cgrad      do m=i+1,j-1
7016 cgrad        do ll=1,3
7017 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7018 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7019 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7020 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7021 cgrad        enddo
7022 cgrad      enddo
7023 cgrad      do m=k+1,l-1
7024 cgrad        do ll=1,3
7025 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7026 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7027 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7028 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7029 cgrad        enddo
7030 cgrad      enddo
7031 c      write (iout,*) "ehbcorr",ekont*ees
7032       ehbcorr=ekont*ees
7033       return
7034       end
7035 #ifdef MOMENT
7036 C---------------------------------------------------------------------------
7037       subroutine dipole(i,j,jj)
7038       implicit real*8 (a-h,o-z)
7039       include 'DIMENSIONS'
7040       include 'COMMON.IOUNITS'
7041       include 'COMMON.CHAIN'
7042       include 'COMMON.FFIELD'
7043       include 'COMMON.DERIV'
7044       include 'COMMON.INTERACT'
7045       include 'COMMON.CONTACTS'
7046       include 'COMMON.TORSION'
7047       include 'COMMON.VAR'
7048       include 'COMMON.GEO'
7049       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7050      &  auxmat(2,2)
7051       iti1 = itortyp(itype(i+1))
7052       if (j.lt.nres-1) then
7053         itj1 = itortyp(itype(j+1))
7054       else
7055         itj1=ntortyp+1
7056       endif
7057       do iii=1,2
7058         dipi(iii,1)=Ub2(iii,i)
7059         dipderi(iii)=Ub2der(iii,i)
7060         dipi(iii,2)=b1(iii,i+1)
7061         dipj(iii,1)=Ub2(iii,j)
7062         dipderj(iii)=Ub2der(iii,j)
7063         dipj(iii,2)=b1(iii,j+1)
7064       enddo
7065       kkk=0
7066       do iii=1,2
7067         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7068         do jjj=1,2
7069           kkk=kkk+1
7070           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7071         enddo
7072       enddo
7073       do kkk=1,5
7074         do lll=1,3
7075           mmm=0
7076           do iii=1,2
7077             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7078      &        auxvec(1))
7079             do jjj=1,2
7080               mmm=mmm+1
7081               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7082             enddo
7083           enddo
7084         enddo
7085       enddo
7086       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7087       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7088       do iii=1,2
7089         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7090       enddo
7091       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7092       do iii=1,2
7093         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7094       enddo
7095       return
7096       end
7097 #endif
7098 C---------------------------------------------------------------------------
7099       subroutine calc_eello(i,j,k,l,jj,kk)
7100 C
7101 C This subroutine computes matrices and vectors needed to calculate
7102 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7103 C
7104       implicit real*8 (a-h,o-z)
7105       include 'DIMENSIONS'
7106       include 'COMMON.IOUNITS'
7107       include 'COMMON.CHAIN'
7108       include 'COMMON.DERIV'
7109       include 'COMMON.INTERACT'
7110       include 'COMMON.CONTACTS'
7111       include 'COMMON.TORSION'
7112       include 'COMMON.VAR'
7113       include 'COMMON.GEO'
7114       include 'COMMON.FFIELD'
7115       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7116      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7117       logical lprn
7118       common /kutas/ lprn
7119 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7120 cd     & ' jj=',jj,' kk=',kk
7121 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7122 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7123 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7124       do iii=1,2
7125         do jjj=1,2
7126           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7127           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7128         enddo
7129       enddo
7130       call transpose2(aa1(1,1),aa1t(1,1))
7131       call transpose2(aa2(1,1),aa2t(1,1))
7132       do kkk=1,5
7133         do lll=1,3
7134           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7135      &      aa1tder(1,1,lll,kkk))
7136           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7137      &      aa2tder(1,1,lll,kkk))
7138         enddo
7139       enddo
7140       if (l.eq.j+1) then
7141 C parallel orientation of the two CA-CA-CA frames.
7142         if (i.gt.1) then
7143           iti=itortyp(itype(i))
7144         else
7145           iti=ntortyp+1
7146         endif
7147         itk1=itortyp(itype(k+1))
7148         itj=itortyp(itype(j))
7149         if (l.lt.nres-1) then
7150           itl1=itortyp(itype(l+1))
7151         else
7152           itl1=ntortyp+1
7153         endif
7154 C A1 kernel(j+1) A2T
7155 cd        do iii=1,2
7156 cd          write (iout,'(3f10.5,5x,3f10.5)')
7157 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7158 cd        enddo
7159         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7160      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7161      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7162 C Following matrices are needed only for 6-th order cumulants
7163         IF (wcorr6.gt.0.0d0) THEN
7164         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7165      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7166      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7167         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7168      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7169      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7170      &   ADtEAderx(1,1,1,1,1,1))
7171         lprn=.false.
7172         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7173      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7174      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7175      &   ADtEA1derx(1,1,1,1,1,1))
7176         ENDIF
7177 C End 6-th order cumulants
7178 cd        lprn=.false.
7179 cd        if (lprn) then
7180 cd        write (2,*) 'In calc_eello6'
7181 cd        do iii=1,2
7182 cd          write (2,*) 'iii=',iii
7183 cd          do kkk=1,5
7184 cd            write (2,*) 'kkk=',kkk
7185 cd            do jjj=1,2
7186 cd              write (2,'(3(2f10.5),5x)')
7187 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7188 cd            enddo
7189 cd          enddo
7190 cd        enddo
7191 cd        endif
7192         call transpose2(EUgder(1,1,k),auxmat(1,1))
7193         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7194         call transpose2(EUg(1,1,k),auxmat(1,1))
7195         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7196         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7197         do iii=1,2
7198           do kkk=1,5
7199             do lll=1,3
7200               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7201      &          EAEAderx(1,1,lll,kkk,iii,1))
7202             enddo
7203           enddo
7204         enddo
7205 C A1T kernel(i+1) A2
7206         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7207      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7208      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7209 C Following matrices are needed only for 6-th order cumulants
7210         IF (wcorr6.gt.0.0d0) THEN
7211         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7212      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7213      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7214         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7215      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7216      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7217      &   ADtEAderx(1,1,1,1,1,2))
7218         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7219      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7220      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7221      &   ADtEA1derx(1,1,1,1,1,2))
7222         ENDIF
7223 C End 6-th order cumulants
7224         call transpose2(EUgder(1,1,l),auxmat(1,1))
7225         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7226         call transpose2(EUg(1,1,l),auxmat(1,1))
7227         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7228         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7229         do iii=1,2
7230           do kkk=1,5
7231             do lll=1,3
7232               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7233      &          EAEAderx(1,1,lll,kkk,iii,2))
7234             enddo
7235           enddo
7236         enddo
7237 C AEAb1 and AEAb2
7238 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7239 C They are needed only when the fifth- or the sixth-order cumulants are
7240 C indluded.
7241         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7242         call transpose2(AEA(1,1,1),auxmat(1,1))
7243         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7244         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7245         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7246         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7247         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7248         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7249         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7250         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7251         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7252         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7253         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7254         call transpose2(AEA(1,1,2),auxmat(1,1))
7255         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7256         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7257         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7258         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7259         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7260         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7261         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7262         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7263         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7264         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7265         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7266 C Calculate the Cartesian derivatives of the vectors.
7267         do iii=1,2
7268           do kkk=1,5
7269             do lll=1,3
7270               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7271               call matvec2(auxmat(1,1),b1(1,i),
7272      &          AEAb1derx(1,lll,kkk,iii,1,1))
7273               call matvec2(auxmat(1,1),Ub2(1,i),
7274      &          AEAb2derx(1,lll,kkk,iii,1,1))
7275               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7276      &          AEAb1derx(1,lll,kkk,iii,2,1))
7277               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7278      &          AEAb2derx(1,lll,kkk,iii,2,1))
7279               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7280               call matvec2(auxmat(1,1),b1(1,j),
7281      &          AEAb1derx(1,lll,kkk,iii,1,2))
7282               call matvec2(auxmat(1,1),Ub2(1,j),
7283      &          AEAb2derx(1,lll,kkk,iii,1,2))
7284               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7285      &          AEAb1derx(1,lll,kkk,iii,2,2))
7286               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7287      &          AEAb2derx(1,lll,kkk,iii,2,2))
7288             enddo
7289           enddo
7290         enddo
7291         ENDIF
7292 C End vectors
7293       else
7294 C Antiparallel orientation of the two CA-CA-CA frames.
7295         if (i.gt.1) then
7296           iti=itortyp(itype(i))
7297         else
7298           iti=ntortyp+1
7299         endif
7300         itk1=itortyp(itype(k+1))
7301         itl=itortyp(itype(l))
7302         itj=itortyp(itype(j))
7303         if (j.lt.nres-1) then
7304           itj1=itortyp(itype(j+1))
7305         else
7306           itj1=ntortyp+1
7307         endif
7308 C A2 kernel(j-1)T A1T
7309         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7310      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7311      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7312 C Following matrices are needed only for 6-th order cumulants
7313         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7314      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7315         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7316      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7317      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7318         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7319      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7320      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7321      &   ADtEAderx(1,1,1,1,1,1))
7322         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7323      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7324      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7325      &   ADtEA1derx(1,1,1,1,1,1))
7326         ENDIF
7327 C End 6-th order cumulants
7328         call transpose2(EUgder(1,1,k),auxmat(1,1))
7329         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7330         call transpose2(EUg(1,1,k),auxmat(1,1))
7331         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7332         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7333         do iii=1,2
7334           do kkk=1,5
7335             do lll=1,3
7336               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7337      &          EAEAderx(1,1,lll,kkk,iii,1))
7338             enddo
7339           enddo
7340         enddo
7341 C A2T kernel(i+1)T A1
7342         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7343      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7344      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7345 C Following matrices are needed only for 6-th order cumulants
7346         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7347      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7348         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7349      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7350      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7351         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7352      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7353      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7354      &   ADtEAderx(1,1,1,1,1,2))
7355         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7356      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7357      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7358      &   ADtEA1derx(1,1,1,1,1,2))
7359         ENDIF
7360 C End 6-th order cumulants
7361         call transpose2(EUgder(1,1,j),auxmat(1,1))
7362         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7363         call transpose2(EUg(1,1,j),auxmat(1,1))
7364         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7365         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7366         do iii=1,2
7367           do kkk=1,5
7368             do lll=1,3
7369               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7370      &          EAEAderx(1,1,lll,kkk,iii,2))
7371             enddo
7372           enddo
7373         enddo
7374 C AEAb1 and AEAb2
7375 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7376 C They are needed only when the fifth- or the sixth-order cumulants are
7377 C indluded.
7378         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7379      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7380         call transpose2(AEA(1,1,1),auxmat(1,1))
7381         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7382         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7383         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7384         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7385         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7386         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7387         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7388         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7389         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7390         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7391         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7392         call transpose2(AEA(1,1,2),auxmat(1,1))
7393         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7394         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7395         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7396         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7397         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7398         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7399         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7400         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7401         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7402         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7403         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7404 C Calculate the Cartesian derivatives of the vectors.
7405         do iii=1,2
7406           do kkk=1,5
7407             do lll=1,3
7408               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7409               call matvec2(auxmat(1,1),b1(1,i),
7410      &          AEAb1derx(1,lll,kkk,iii,1,1))
7411               call matvec2(auxmat(1,1),Ub2(1,i),
7412      &          AEAb2derx(1,lll,kkk,iii,1,1))
7413               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7414      &          AEAb1derx(1,lll,kkk,iii,2,1))
7415               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7416      &          AEAb2derx(1,lll,kkk,iii,2,1))
7417               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7418               call matvec2(auxmat(1,1),b1(1,l),
7419      &          AEAb1derx(1,lll,kkk,iii,1,2))
7420               call matvec2(auxmat(1,1),Ub2(1,l),
7421      &          AEAb2derx(1,lll,kkk,iii,1,2))
7422               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7423      &          AEAb1derx(1,lll,kkk,iii,2,2))
7424               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7425      &          AEAb2derx(1,lll,kkk,iii,2,2))
7426             enddo
7427           enddo
7428         enddo
7429         ENDIF
7430 C End vectors
7431       endif
7432       return
7433       end
7434 C---------------------------------------------------------------------------
7435       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7436      &  KK,KKderg,AKA,AKAderg,AKAderx)
7437       implicit none
7438       integer nderg
7439       logical transp
7440       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7441      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7442      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7443       integer iii,kkk,lll
7444       integer jjj,mmm
7445       logical lprn
7446       common /kutas/ lprn
7447       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7448       do iii=1,nderg
7449         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7450      &    AKAderg(1,1,iii))
7451       enddo
7452 cd      if (lprn) write (2,*) 'In kernel'
7453       do kkk=1,5
7454 cd        if (lprn) write (2,*) 'kkk=',kkk
7455         do lll=1,3
7456           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7457      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7458 cd          if (lprn) then
7459 cd            write (2,*) 'lll=',lll
7460 cd            write (2,*) 'iii=1'
7461 cd            do jjj=1,2
7462 cd              write (2,'(3(2f10.5),5x)')
7463 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7464 cd            enddo
7465 cd          endif
7466           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7467      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7468 cd          if (lprn) then
7469 cd            write (2,*) 'lll=',lll
7470 cd            write (2,*) 'iii=2'
7471 cd            do jjj=1,2
7472 cd              write (2,'(3(2f10.5),5x)')
7473 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7474 cd            enddo
7475 cd          endif
7476         enddo
7477       enddo
7478       return
7479       end
7480 C---------------------------------------------------------------------------
7481       double precision function eello4(i,j,k,l,jj,kk)
7482       implicit real*8 (a-h,o-z)
7483       include 'DIMENSIONS'
7484       include 'COMMON.IOUNITS'
7485       include 'COMMON.CHAIN'
7486       include 'COMMON.DERIV'
7487       include 'COMMON.INTERACT'
7488       include 'COMMON.CONTACTS'
7489       include 'COMMON.TORSION'
7490       include 'COMMON.VAR'
7491       include 'COMMON.GEO'
7492       double precision pizda(2,2),ggg1(3),ggg2(3)
7493 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7494 cd        eello4=0.0d0
7495 cd        return
7496 cd      endif
7497 cd      print *,'eello4:',i,j,k,l,jj,kk
7498 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7499 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7500 cold      eij=facont_hb(jj,i)
7501 cold      ekl=facont_hb(kk,k)
7502 cold      ekont=eij*ekl
7503       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7504 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7505       gcorr_loc(k-1)=gcorr_loc(k-1)
7506      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7507       if (l.eq.j+1) then
7508         gcorr_loc(l-1)=gcorr_loc(l-1)
7509      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7510       else
7511         gcorr_loc(j-1)=gcorr_loc(j-1)
7512      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7513       endif
7514       do iii=1,2
7515         do kkk=1,5
7516           do lll=1,3
7517             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7518      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7519 cd            derx(lll,kkk,iii)=0.0d0
7520           enddo
7521         enddo
7522       enddo
7523 cd      gcorr_loc(l-1)=0.0d0
7524 cd      gcorr_loc(j-1)=0.0d0
7525 cd      gcorr_loc(k-1)=0.0d0
7526 cd      eel4=1.0d0
7527 cd      write (iout,*)'Contacts have occurred for peptide groups',
7528 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7529 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7530       if (j.lt.nres-1) then
7531         j1=j+1
7532         j2=j-1
7533       else
7534         j1=j-1
7535         j2=j-2
7536       endif
7537       if (l.lt.nres-1) then
7538         l1=l+1
7539         l2=l-1
7540       else
7541         l1=l-1
7542         l2=l-2
7543       endif
7544       do ll=1,3
7545 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7546 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7547         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7548         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7549 cgrad        ghalf=0.5d0*ggg1(ll)
7550         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7551         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7552         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7553         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7554         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7555         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7556 cgrad        ghalf=0.5d0*ggg2(ll)
7557         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7558         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7559         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7560         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7561         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7562         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7563       enddo
7564 cgrad      do m=i+1,j-1
7565 cgrad        do ll=1,3
7566 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7567 cgrad        enddo
7568 cgrad      enddo
7569 cgrad      do m=k+1,l-1
7570 cgrad        do ll=1,3
7571 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7572 cgrad        enddo
7573 cgrad      enddo
7574 cgrad      do m=i+2,j2
7575 cgrad        do ll=1,3
7576 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7577 cgrad        enddo
7578 cgrad      enddo
7579 cgrad      do m=k+2,l2
7580 cgrad        do ll=1,3
7581 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7582 cgrad        enddo
7583 cgrad      enddo
7584 cd      do iii=1,nres-3
7585 cd        write (2,*) iii,gcorr_loc(iii)
7586 cd      enddo
7587       eello4=ekont*eel4
7588 cd      write (2,*) 'ekont',ekont
7589 cd      write (iout,*) 'eello4',ekont*eel4
7590       return
7591       end
7592 C---------------------------------------------------------------------------
7593       double precision function eello5(i,j,k,l,jj,kk)
7594       implicit real*8 (a-h,o-z)
7595       include 'DIMENSIONS'
7596       include 'COMMON.IOUNITS'
7597       include 'COMMON.CHAIN'
7598       include 'COMMON.DERIV'
7599       include 'COMMON.INTERACT'
7600       include 'COMMON.CONTACTS'
7601       include 'COMMON.TORSION'
7602       include 'COMMON.VAR'
7603       include 'COMMON.GEO'
7604       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7605       double precision ggg1(3),ggg2(3)
7606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7607 C                                                                              C
7608 C                            Parallel chains                                   C
7609 C                                                                              C
7610 C          o             o                   o             o                   C
7611 C         /l\           / \             \   / \           / \   /              C
7612 C        /   \         /   \             \ /   \         /   \ /               C
7613 C       j| o |l1       | o |              o| o |         | o |o                C
7614 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7615 C      \i/   \         /   \ /             /   \         /   \                 C
7616 C       o    k1             o                                                  C
7617 C         (I)          (II)                (III)          (IV)                 C
7618 C                                                                              C
7619 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7620 C                                                                              C
7621 C                            Antiparallel chains                               C
7622 C                                                                              C
7623 C          o             o                   o             o                   C
7624 C         /j\           / \             \   / \           / \   /              C
7625 C        /   \         /   \             \ /   \         /   \ /               C
7626 C      j1| o |l        | o |              o| o |         | o |o                C
7627 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7628 C      \i/   \         /   \ /             /   \         /   \                 C
7629 C       o     k1            o                                                  C
7630 C         (I)          (II)                (III)          (IV)                 C
7631 C                                                                              C
7632 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7633 C                                                                              C
7634 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7635 C                                                                              C
7636 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7637 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7638 cd        eello5=0.0d0
7639 cd        return
7640 cd      endif
7641 cd      write (iout,*)
7642 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7643 cd     &   ' and',k,l
7644       itk=itortyp(itype(k))
7645       itl=itortyp(itype(l))
7646       itj=itortyp(itype(j))
7647       eello5_1=0.0d0
7648       eello5_2=0.0d0
7649       eello5_3=0.0d0
7650       eello5_4=0.0d0
7651 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7652 cd     &   eel5_3_num,eel5_4_num)
7653       do iii=1,2
7654         do kkk=1,5
7655           do lll=1,3
7656             derx(lll,kkk,iii)=0.0d0
7657           enddo
7658         enddo
7659       enddo
7660 cd      eij=facont_hb(jj,i)
7661 cd      ekl=facont_hb(kk,k)
7662 cd      ekont=eij*ekl
7663 cd      write (iout,*)'Contacts have occurred for peptide groups',
7664 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7665 cd      goto 1111
7666 C Contribution from the graph I.
7667 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7668 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7669       call transpose2(EUg(1,1,k),auxmat(1,1))
7670       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7671       vv(1)=pizda(1,1)-pizda(2,2)
7672       vv(2)=pizda(1,2)+pizda(2,1)
7673       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7674      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7675 C Explicit gradient in virtual-dihedral angles.
7676       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7677      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7678      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7679       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7680       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7681       vv(1)=pizda(1,1)-pizda(2,2)
7682       vv(2)=pizda(1,2)+pizda(2,1)
7683       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7684      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7685      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7686       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7687       vv(1)=pizda(1,1)-pizda(2,2)
7688       vv(2)=pizda(1,2)+pizda(2,1)
7689       if (l.eq.j+1) then
7690         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7691      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7692      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7693       else
7694         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7695      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7696      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7697       endif
7698 C Cartesian gradient
7699       do iii=1,2
7700         do kkk=1,5
7701           do lll=1,3
7702             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7703      &        pizda(1,1))
7704             vv(1)=pizda(1,1)-pizda(2,2)
7705             vv(2)=pizda(1,2)+pizda(2,1)
7706             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7707      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7708      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7709           enddo
7710         enddo
7711       enddo
7712 c      goto 1112
7713 c1111  continue
7714 C Contribution from graph II
7715       call transpose2(EE(1,1,itk),auxmat(1,1))
7716       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7717       vv(1)=pizda(1,1)+pizda(2,2)
7718       vv(2)=pizda(2,1)-pizda(1,2)
7719       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7720      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7721 C Explicit gradient in virtual-dihedral angles.
7722       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7723      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7724       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7725       vv(1)=pizda(1,1)+pizda(2,2)
7726       vv(2)=pizda(2,1)-pizda(1,2)
7727       if (l.eq.j+1) then
7728         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7729      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7730      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7731       else
7732         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7733      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7734      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7735       endif
7736 C Cartesian gradient
7737       do iii=1,2
7738         do kkk=1,5
7739           do lll=1,3
7740             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7741      &        pizda(1,1))
7742             vv(1)=pizda(1,1)+pizda(2,2)
7743             vv(2)=pizda(2,1)-pizda(1,2)
7744             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7745      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7746      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7747           enddo
7748         enddo
7749       enddo
7750 cd      goto 1112
7751 cd1111  continue
7752       if (l.eq.j+1) then
7753 cd        goto 1110
7754 C Parallel orientation
7755 C Contribution from graph III
7756         call transpose2(EUg(1,1,l),auxmat(1,1))
7757         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7758         vv(1)=pizda(1,1)-pizda(2,2)
7759         vv(2)=pizda(1,2)+pizda(2,1)
7760         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7761      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7762 C Explicit gradient in virtual-dihedral angles.
7763         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7764      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7765      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7766         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7767         vv(1)=pizda(1,1)-pizda(2,2)
7768         vv(2)=pizda(1,2)+pizda(2,1)
7769         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7770      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7771      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7772         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7773         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7774         vv(1)=pizda(1,1)-pizda(2,2)
7775         vv(2)=pizda(1,2)+pizda(2,1)
7776         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7777      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7778      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7779 C Cartesian gradient
7780         do iii=1,2
7781           do kkk=1,5
7782             do lll=1,3
7783               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7784      &          pizda(1,1))
7785               vv(1)=pizda(1,1)-pizda(2,2)
7786               vv(2)=pizda(1,2)+pizda(2,1)
7787               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7788      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7789      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7790             enddo
7791           enddo
7792         enddo
7793 cd        goto 1112
7794 C Contribution from graph IV
7795 cd1110    continue
7796         call transpose2(EE(1,1,itl),auxmat(1,1))
7797         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7798         vv(1)=pizda(1,1)+pizda(2,2)
7799         vv(2)=pizda(2,1)-pizda(1,2)
7800         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7801      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7802 C Explicit gradient in virtual-dihedral angles.
7803         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7804      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7805         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7806         vv(1)=pizda(1,1)+pizda(2,2)
7807         vv(2)=pizda(2,1)-pizda(1,2)
7808         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7809      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7810      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7811 C Cartesian gradient
7812         do iii=1,2
7813           do kkk=1,5
7814             do lll=1,3
7815               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7816      &          pizda(1,1))
7817               vv(1)=pizda(1,1)+pizda(2,2)
7818               vv(2)=pizda(2,1)-pizda(1,2)
7819               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7820      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7821      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7822             enddo
7823           enddo
7824         enddo
7825       else
7826 C Antiparallel orientation
7827 C Contribution from graph III
7828 c        goto 1110
7829         call transpose2(EUg(1,1,j),auxmat(1,1))
7830         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7831         vv(1)=pizda(1,1)-pizda(2,2)
7832         vv(2)=pizda(1,2)+pizda(2,1)
7833         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7834      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7835 C Explicit gradient in virtual-dihedral angles.
7836         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7837      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7838      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7839         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7840         vv(1)=pizda(1,1)-pizda(2,2)
7841         vv(2)=pizda(1,2)+pizda(2,1)
7842         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7843      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7844      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7845         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7846         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7847         vv(1)=pizda(1,1)-pizda(2,2)
7848         vv(2)=pizda(1,2)+pizda(2,1)
7849         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7850      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7851      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7852 C Cartesian gradient
7853         do iii=1,2
7854           do kkk=1,5
7855             do lll=1,3
7856               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7857      &          pizda(1,1))
7858               vv(1)=pizda(1,1)-pizda(2,2)
7859               vv(2)=pizda(1,2)+pizda(2,1)
7860               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7861      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7862      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7863             enddo
7864           enddo
7865         enddo
7866 cd        goto 1112
7867 C Contribution from graph IV
7868 1110    continue
7869         call transpose2(EE(1,1,itj),auxmat(1,1))
7870         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7871         vv(1)=pizda(1,1)+pizda(2,2)
7872         vv(2)=pizda(2,1)-pizda(1,2)
7873         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7874      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7875 C Explicit gradient in virtual-dihedral angles.
7876         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7877      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7878         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7879         vv(1)=pizda(1,1)+pizda(2,2)
7880         vv(2)=pizda(2,1)-pizda(1,2)
7881         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7882      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7883      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7884 C Cartesian gradient
7885         do iii=1,2
7886           do kkk=1,5
7887             do lll=1,3
7888               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7889      &          pizda(1,1))
7890               vv(1)=pizda(1,1)+pizda(2,2)
7891               vv(2)=pizda(2,1)-pizda(1,2)
7892               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7893      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7894      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7895             enddo
7896           enddo
7897         enddo
7898       endif
7899 1112  continue
7900       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7901 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7902 cd        write (2,*) 'ijkl',i,j,k,l
7903 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7904 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7905 cd      endif
7906 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7907 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7908 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7909 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7910       if (j.lt.nres-1) then
7911         j1=j+1
7912         j2=j-1
7913       else
7914         j1=j-1
7915         j2=j-2
7916       endif
7917       if (l.lt.nres-1) then
7918         l1=l+1
7919         l2=l-1
7920       else
7921         l1=l-1
7922         l2=l-2
7923       endif
7924 cd      eij=1.0d0
7925 cd      ekl=1.0d0
7926 cd      ekont=1.0d0
7927 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7928 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7929 C        summed up outside the subrouine as for the other subroutines
7930 C        handling long-range interactions. The old code is commented out
7931 C        with "cgrad" to keep track of changes.
7932       do ll=1,3
7933 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7934 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7935         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7936         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7937 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7938 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7939 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7940 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7941 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7942 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7943 c     &   gradcorr5ij,
7944 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7945 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7946 cgrad        ghalf=0.5d0*ggg1(ll)
7947 cd        ghalf=0.0d0
7948         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7949         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7950         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7951         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7952         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7953         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7954 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7955 cgrad        ghalf=0.5d0*ggg2(ll)
7956 cd        ghalf=0.0d0
7957         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7958         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7959         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7960         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7961         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7962         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7963       enddo
7964 cd      goto 1112
7965 cgrad      do m=i+1,j-1
7966 cgrad        do ll=1,3
7967 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7968 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7969 cgrad        enddo
7970 cgrad      enddo
7971 cgrad      do m=k+1,l-1
7972 cgrad        do ll=1,3
7973 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7974 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7975 cgrad        enddo
7976 cgrad      enddo
7977 c1112  continue
7978 cgrad      do m=i+2,j2
7979 cgrad        do ll=1,3
7980 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7981 cgrad        enddo
7982 cgrad      enddo
7983 cgrad      do m=k+2,l2
7984 cgrad        do ll=1,3
7985 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7986 cgrad        enddo
7987 cgrad      enddo
7988 cd      do iii=1,nres-3
7989 cd        write (2,*) iii,g_corr5_loc(iii)
7990 cd      enddo
7991       eello5=ekont*eel5
7992 cd      write (2,*) 'ekont',ekont
7993 cd      write (iout,*) 'eello5',ekont*eel5
7994       return
7995       end
7996 c--------------------------------------------------------------------------
7997       double precision function eello6(i,j,k,l,jj,kk)
7998       implicit real*8 (a-h,o-z)
7999       include 'DIMENSIONS'
8000       include 'COMMON.IOUNITS'
8001       include 'COMMON.CHAIN'
8002       include 'COMMON.DERIV'
8003       include 'COMMON.INTERACT'
8004       include 'COMMON.CONTACTS'
8005       include 'COMMON.TORSION'
8006       include 'COMMON.VAR'
8007       include 'COMMON.GEO'
8008       include 'COMMON.FFIELD'
8009       double precision ggg1(3),ggg2(3)
8010 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8011 cd        eello6=0.0d0
8012 cd        return
8013 cd      endif
8014 cd      write (iout,*)
8015 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8016 cd     &   ' and',k,l
8017       eello6_1=0.0d0
8018       eello6_2=0.0d0
8019       eello6_3=0.0d0
8020       eello6_4=0.0d0
8021       eello6_5=0.0d0
8022       eello6_6=0.0d0
8023 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8024 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8025       do iii=1,2
8026         do kkk=1,5
8027           do lll=1,3
8028             derx(lll,kkk,iii)=0.0d0
8029           enddo
8030         enddo
8031       enddo
8032 cd      eij=facont_hb(jj,i)
8033 cd      ekl=facont_hb(kk,k)
8034 cd      ekont=eij*ekl
8035 cd      eij=1.0d0
8036 cd      ekl=1.0d0
8037 cd      ekont=1.0d0
8038       if (l.eq.j+1) then
8039         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8040         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8041         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8042         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8043         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8044         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8045       else
8046         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8047         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8048         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8049         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8050         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8051           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8052         else
8053           eello6_5=0.0d0
8054         endif
8055         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8056       endif
8057 C If turn contributions are considered, they will be handled separately.
8058       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8059 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8060 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8061 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8062 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8063 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8064 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8065 cd      goto 1112
8066       if (j.lt.nres-1) then
8067         j1=j+1
8068         j2=j-1
8069       else
8070         j1=j-1
8071         j2=j-2
8072       endif
8073       if (l.lt.nres-1) then
8074         l1=l+1
8075         l2=l-1
8076       else
8077         l1=l-1
8078         l2=l-2
8079       endif
8080       do ll=1,3
8081 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8082 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8083 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8084 cgrad        ghalf=0.5d0*ggg1(ll)
8085 cd        ghalf=0.0d0
8086         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8087         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8088         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8089         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8090         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8091         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8092         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8093         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8094 cgrad        ghalf=0.5d0*ggg2(ll)
8095 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8096 cd        ghalf=0.0d0
8097         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8098         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8099         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8100         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8101         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8102         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8103       enddo
8104 cd      goto 1112
8105 cgrad      do m=i+1,j-1
8106 cgrad        do ll=1,3
8107 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8108 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8109 cgrad        enddo
8110 cgrad      enddo
8111 cgrad      do m=k+1,l-1
8112 cgrad        do ll=1,3
8113 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8114 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8115 cgrad        enddo
8116 cgrad      enddo
8117 cgrad1112  continue
8118 cgrad      do m=i+2,j2
8119 cgrad        do ll=1,3
8120 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8121 cgrad        enddo
8122 cgrad      enddo
8123 cgrad      do m=k+2,l2
8124 cgrad        do ll=1,3
8125 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8126 cgrad        enddo
8127 cgrad      enddo
8128 cd      do iii=1,nres-3
8129 cd        write (2,*) iii,g_corr6_loc(iii)
8130 cd      enddo
8131       eello6=ekont*eel6
8132 cd      write (2,*) 'ekont',ekont
8133 cd      write (iout,*) 'eello6',ekont*eel6
8134       return
8135       end
8136 c--------------------------------------------------------------------------
8137       double precision function eello6_graph1(i,j,k,l,imat,swap)
8138       implicit real*8 (a-h,o-z)
8139       include 'DIMENSIONS'
8140       include 'COMMON.IOUNITS'
8141       include 'COMMON.CHAIN'
8142       include 'COMMON.DERIV'
8143       include 'COMMON.INTERACT'
8144       include 'COMMON.CONTACTS'
8145       include 'COMMON.TORSION'
8146       include 'COMMON.VAR'
8147       include 'COMMON.GEO'
8148       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8149       logical swap
8150       logical lprn
8151       common /kutas/ lprn
8152 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8153 C                                                                              C
8154 C      Parallel       Antiparallel                                             C
8155 C                                                                              C
8156 C          o             o                                                     C
8157 C         /l\           /j\                                                    C
8158 C        /   \         /   \                                                   C
8159 C       /| o |         | o |\                                                  C
8160 C     \ j|/k\|  /   \  |/k\|l /                                                C
8161 C      \ /   \ /     \ /   \ /                                                 C
8162 C       o     o       o     o                                                  C
8163 C       i             i                                                        C
8164 C                                                                              C
8165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8166       itk=itortyp(itype(k))
8167       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8168       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8169       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8170       call transpose2(EUgC(1,1,k),auxmat(1,1))
8171       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8172       vv1(1)=pizda1(1,1)-pizda1(2,2)
8173       vv1(2)=pizda1(1,2)+pizda1(2,1)
8174       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8175       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8176       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8177       s5=scalar2(vv(1),Dtobr2(1,i))
8178 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8179       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8180       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8181      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8182      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8183      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8184      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8185      & +scalar2(vv(1),Dtobr2der(1,i)))
8186       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8187       vv1(1)=pizda1(1,1)-pizda1(2,2)
8188       vv1(2)=pizda1(1,2)+pizda1(2,1)
8189       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8190       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8191       if (l.eq.j+1) then
8192         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8193      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8194      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8195      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8196      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8197       else
8198         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8199      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8200      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8201      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8202      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8203       endif
8204       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8205       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8206       vv1(1)=pizda1(1,1)-pizda1(2,2)
8207       vv1(2)=pizda1(1,2)+pizda1(2,1)
8208       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8209      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8210      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8211      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8212       do iii=1,2
8213         if (swap) then
8214           ind=3-iii
8215         else
8216           ind=iii
8217         endif
8218         do kkk=1,5
8219           do lll=1,3
8220             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8221             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8222             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8223             call transpose2(EUgC(1,1,k),auxmat(1,1))
8224             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8225      &        pizda1(1,1))
8226             vv1(1)=pizda1(1,1)-pizda1(2,2)
8227             vv1(2)=pizda1(1,2)+pizda1(2,1)
8228             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8229             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8230      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8231             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8232      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8233             s5=scalar2(vv(1),Dtobr2(1,i))
8234             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8235           enddo
8236         enddo
8237       enddo
8238       return
8239       end
8240 c----------------------------------------------------------------------------
8241       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8242       implicit real*8 (a-h,o-z)
8243       include 'DIMENSIONS'
8244       include 'COMMON.IOUNITS'
8245       include 'COMMON.CHAIN'
8246       include 'COMMON.DERIV'
8247       include 'COMMON.INTERACT'
8248       include 'COMMON.CONTACTS'
8249       include 'COMMON.TORSION'
8250       include 'COMMON.VAR'
8251       include 'COMMON.GEO'
8252       logical swap
8253       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8254      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8255       logical lprn
8256       common /kutas/ lprn
8257 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8258 C                                                                              C
8259 C      Parallel       Antiparallel                                             C
8260 C                                                                              C
8261 C          o             o                                                     C
8262 C     \   /l\           /j\   /                                                C
8263 C      \ /   \         /   \ /                                                 C
8264 C       o| o |         | o |o                                                  C
8265 C     \ j|/k\|      \  |/k\|l                                                  C
8266 C      \ /   \       \ /   \                                                   C
8267 C       o             o                                                        C
8268 C       i             i                                                        C
8269 C                                                                              C
8270 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8271 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8272 C AL 7/4/01 s1 would occur in the sixth-order moment,
8273 C           but not in a cluster cumulant
8274 #ifdef MOMENT
8275       s1=dip(1,jj,i)*dip(1,kk,k)
8276 #endif
8277       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8278       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8279       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8280       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8281       call transpose2(EUg(1,1,k),auxmat(1,1))
8282       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8283       vv(1)=pizda(1,1)-pizda(2,2)
8284       vv(2)=pizda(1,2)+pizda(2,1)
8285       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8286 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8287 #ifdef MOMENT
8288       eello6_graph2=-(s1+s2+s3+s4)
8289 #else
8290       eello6_graph2=-(s2+s3+s4)
8291 #endif
8292 c      eello6_graph2=-s3
8293 C Derivatives in gamma(i-1)
8294       if (i.gt.1) then
8295 #ifdef MOMENT
8296         s1=dipderg(1,jj,i)*dip(1,kk,k)
8297 #endif
8298         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8299         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8300         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8301         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8302 #ifdef MOMENT
8303         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8304 #else
8305         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8306 #endif
8307 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8308       endif
8309 C Derivatives in gamma(k-1)
8310 #ifdef MOMENT
8311       s1=dip(1,jj,i)*dipderg(1,kk,k)
8312 #endif
8313       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8314       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8315       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8316       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8317       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8318       call matmat2(ADtEA1(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       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8322 #ifdef MOMENT
8323       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8324 #else
8325       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8326 #endif
8327 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8328 C Derivatives in gamma(j-1) or gamma(l-1)
8329       if (j.gt.1) then
8330 #ifdef MOMENT
8331         s1=dipderg(3,jj,i)*dip(1,kk,k)
8332 #endif
8333         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8334         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8335         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8336         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8337         vv(1)=pizda(1,1)-pizda(2,2)
8338         vv(2)=pizda(1,2)+pizda(2,1)
8339         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8340 #ifdef MOMENT
8341         if (swap) then
8342           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8343         else
8344           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8345         endif
8346 #endif
8347         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8348 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8349       endif
8350 C Derivatives in gamma(l-1) or gamma(j-1)
8351       if (l.gt.1) then
8352 #ifdef MOMENT
8353         s1=dip(1,jj,i)*dipderg(3,kk,k)
8354 #endif
8355         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8356         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8357         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8358         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8359         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8360         vv(1)=pizda(1,1)-pizda(2,2)
8361         vv(2)=pizda(1,2)+pizda(2,1)
8362         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8363 #ifdef MOMENT
8364         if (swap) then
8365           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8366         else
8367           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8368         endif
8369 #endif
8370         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8371 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8372       endif
8373 C Cartesian derivatives.
8374       if (lprn) then
8375         write (2,*) 'In eello6_graph2'
8376         do iii=1,2
8377           write (2,*) 'iii=',iii
8378           do kkk=1,5
8379             write (2,*) 'kkk=',kkk
8380             do jjj=1,2
8381               write (2,'(3(2f10.5),5x)')
8382      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8383             enddo
8384           enddo
8385         enddo
8386       endif
8387       do iii=1,2
8388         do kkk=1,5
8389           do lll=1,3
8390 #ifdef MOMENT
8391             if (iii.eq.1) then
8392               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8393             else
8394               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8395             endif
8396 #endif
8397             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8398      &        auxvec(1))
8399             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8400             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8401      &        auxvec(1))
8402             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8403             call transpose2(EUg(1,1,k),auxmat(1,1))
8404             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8405      &        pizda(1,1))
8406             vv(1)=pizda(1,1)-pizda(2,2)
8407             vv(2)=pizda(1,2)+pizda(2,1)
8408             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8409 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8410 #ifdef MOMENT
8411             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8412 #else
8413             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8414 #endif
8415             if (swap) then
8416               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8417             else
8418               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8419             endif
8420           enddo
8421         enddo
8422       enddo
8423       return
8424       end
8425 c----------------------------------------------------------------------------
8426       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8427       implicit real*8 (a-h,o-z)
8428       include 'DIMENSIONS'
8429       include 'COMMON.IOUNITS'
8430       include 'COMMON.CHAIN'
8431       include 'COMMON.DERIV'
8432       include 'COMMON.INTERACT'
8433       include 'COMMON.CONTACTS'
8434       include 'COMMON.TORSION'
8435       include 'COMMON.VAR'
8436       include 'COMMON.GEO'
8437       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8438       logical swap
8439 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8440 C                                                                              C
8441 C      Parallel       Antiparallel                                             C
8442 C                                                                              C
8443 C          o             o                                                     C
8444 C         /l\   /   \   /j\                                                    C
8445 C        /   \ /     \ /   \                                                   C
8446 C       /| o |o       o| o |\                                                  C
8447 C       j|/k\|  /      |/k\|l /                                                C
8448 C        /   \ /       /   \ /                                                 C
8449 C       /     o       /     o                                                  C
8450 C       i             i                                                        C
8451 C                                                                              C
8452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8453 C
8454 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8455 C           energy moment and not to the cluster cumulant.
8456       iti=itortyp(itype(i))
8457       if (j.lt.nres-1) then
8458         itj1=itortyp(itype(j+1))
8459       else
8460         itj1=ntortyp+1
8461       endif
8462       itk=itortyp(itype(k))
8463       itk1=itortyp(itype(k+1))
8464       if (l.lt.nres-1) then
8465         itl1=itortyp(itype(l+1))
8466       else
8467         itl1=ntortyp+1
8468       endif
8469 #ifdef MOMENT
8470       s1=dip(4,jj,i)*dip(4,kk,k)
8471 #endif
8472       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8473       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8474       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8475       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8476       call transpose2(EE(1,1,itk),auxmat(1,1))
8477       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8478       vv(1)=pizda(1,1)+pizda(2,2)
8479       vv(2)=pizda(2,1)-pizda(1,2)
8480       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8481 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8482 cd     & "sum",-(s2+s3+s4)
8483 #ifdef MOMENT
8484       eello6_graph3=-(s1+s2+s3+s4)
8485 #else
8486       eello6_graph3=-(s2+s3+s4)
8487 #endif
8488 c      eello6_graph3=-s4
8489 C Derivatives in gamma(k-1)
8490       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8491       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8492       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8493       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8494 C Derivatives in gamma(l-1)
8495       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8496       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8497       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8498       vv(1)=pizda(1,1)+pizda(2,2)
8499       vv(2)=pizda(2,1)-pizda(1,2)
8500       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8501       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8502 C Cartesian derivatives.
8503       do iii=1,2
8504         do kkk=1,5
8505           do lll=1,3
8506 #ifdef MOMENT
8507             if (iii.eq.1) then
8508               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8509             else
8510               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8511             endif
8512 #endif
8513             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8514      &        auxvec(1))
8515             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8516             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8517      &        auxvec(1))
8518             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8519             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8520      &        pizda(1,1))
8521             vv(1)=pizda(1,1)+pizda(2,2)
8522             vv(2)=pizda(2,1)-pizda(1,2)
8523             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8524 #ifdef MOMENT
8525             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8526 #else
8527             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8528 #endif
8529             if (swap) then
8530               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8531             else
8532               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8533             endif
8534 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8535           enddo
8536         enddo
8537       enddo
8538       return
8539       end
8540 c----------------------------------------------------------------------------
8541       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8542       implicit real*8 (a-h,o-z)
8543       include 'DIMENSIONS'
8544       include 'COMMON.IOUNITS'
8545       include 'COMMON.CHAIN'
8546       include 'COMMON.DERIV'
8547       include 'COMMON.INTERACT'
8548       include 'COMMON.CONTACTS'
8549       include 'COMMON.TORSION'
8550       include 'COMMON.VAR'
8551       include 'COMMON.GEO'
8552       include 'COMMON.FFIELD'
8553       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8554      & auxvec1(2),auxmat1(2,2)
8555       logical swap
8556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8557 C                                                                              C
8558 C      Parallel       Antiparallel                                             C
8559 C                                                                              C
8560 C          o             o                                                     C
8561 C         /l\   /   \   /j\                                                    C
8562 C        /   \ /     \ /   \                                                   C
8563 C       /| o |o       o| o |\                                                  C
8564 C     \ j|/k\|      \  |/k\|l                                                  C
8565 C      \ /   \       \ /   \                                                   C
8566 C       o     \       o     \                                                  C
8567 C       i             i                                                        C
8568 C                                                                              C
8569 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8570 C
8571 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8572 C           energy moment and not to the cluster cumulant.
8573 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8574       iti=itortyp(itype(i))
8575       itj=itortyp(itype(j))
8576       if (j.lt.nres-1) then
8577         itj1=itortyp(itype(j+1))
8578       else
8579         itj1=ntortyp+1
8580       endif
8581       itk=itortyp(itype(k))
8582       if (k.lt.nres-1) then
8583         itk1=itortyp(itype(k+1))
8584       else
8585         itk1=ntortyp+1
8586       endif
8587       itl=itortyp(itype(l))
8588       if (l.lt.nres-1) then
8589         itl1=itortyp(itype(l+1))
8590       else
8591         itl1=ntortyp+1
8592       endif
8593 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8594 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8595 cd     & ' itl',itl,' itl1',itl1
8596 #ifdef MOMENT
8597       if (imat.eq.1) then
8598         s1=dip(3,jj,i)*dip(3,kk,k)
8599       else
8600         s1=dip(2,jj,j)*dip(2,kk,l)
8601       endif
8602 #endif
8603       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8604       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8605       if (j.eq.l+1) then
8606         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8607         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8608       else
8609         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8610         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8611       endif
8612       call transpose2(EUg(1,1,k),auxmat(1,1))
8613       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8614       vv(1)=pizda(1,1)-pizda(2,2)
8615       vv(2)=pizda(2,1)+pizda(1,2)
8616       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8617 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8618 #ifdef MOMENT
8619       eello6_graph4=-(s1+s2+s3+s4)
8620 #else
8621       eello6_graph4=-(s2+s3+s4)
8622 #endif
8623 C Derivatives in gamma(i-1)
8624       if (i.gt.1) then
8625 #ifdef MOMENT
8626         if (imat.eq.1) then
8627           s1=dipderg(2,jj,i)*dip(3,kk,k)
8628         else
8629           s1=dipderg(4,jj,j)*dip(2,kk,l)
8630         endif
8631 #endif
8632         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8633         if (j.eq.l+1) then
8634           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8635           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8636         else
8637           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8638           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8639         endif
8640         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8641         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8642 cd          write (2,*) 'turn6 derivatives'
8643 #ifdef MOMENT
8644           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8645 #else
8646           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8647 #endif
8648         else
8649 #ifdef MOMENT
8650           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8651 #else
8652           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8653 #endif
8654         endif
8655       endif
8656 C Derivatives in gamma(k-1)
8657 #ifdef MOMENT
8658       if (imat.eq.1) then
8659         s1=dip(3,jj,i)*dipderg(2,kk,k)
8660       else
8661         s1=dip(2,jj,j)*dipderg(4,kk,l)
8662       endif
8663 #endif
8664       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8665       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8666       if (j.eq.l+1) then
8667         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8668         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8669       else
8670         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8671         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8672       endif
8673       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8674       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8675       vv(1)=pizda(1,1)-pizda(2,2)
8676       vv(2)=pizda(2,1)+pizda(1,2)
8677       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8678       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8679 #ifdef MOMENT
8680         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8681 #else
8682         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8683 #endif
8684       else
8685 #ifdef MOMENT
8686         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8687 #else
8688         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8689 #endif
8690       endif
8691 C Derivatives in gamma(j-1) or gamma(l-1)
8692       if (l.eq.j+1 .and. l.gt.1) then
8693         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8694         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8695         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8696         vv(1)=pizda(1,1)-pizda(2,2)
8697         vv(2)=pizda(2,1)+pizda(1,2)
8698         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8699         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8700       else if (j.gt.1) then
8701         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8702         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8703         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8704         vv(1)=pizda(1,1)-pizda(2,2)
8705         vv(2)=pizda(2,1)+pizda(1,2)
8706         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8707         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8708           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8709         else
8710           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8711         endif
8712       endif
8713 C Cartesian derivatives.
8714       do iii=1,2
8715         do kkk=1,5
8716           do lll=1,3
8717 #ifdef MOMENT
8718             if (iii.eq.1) then
8719               if (imat.eq.1) then
8720                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8721               else
8722                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8723               endif
8724             else
8725               if (imat.eq.1) then
8726                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8727               else
8728                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8729               endif
8730             endif
8731 #endif
8732             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8733      &        auxvec(1))
8734             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8735             if (j.eq.l+1) then
8736               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8737      &          b1(1,j+1),auxvec(1))
8738               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8739             else
8740               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8741      &          b1(1,l+1),auxvec(1))
8742               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8743             endif
8744             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8745      &        pizda(1,1))
8746             vv(1)=pizda(1,1)-pizda(2,2)
8747             vv(2)=pizda(2,1)+pizda(1,2)
8748             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8749             if (swap) then
8750               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8751 #ifdef MOMENT
8752                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8753      &             -(s1+s2+s4)
8754 #else
8755                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8756      &             -(s2+s4)
8757 #endif
8758                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8759               else
8760 #ifdef MOMENT
8761                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8762 #else
8763                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8764 #endif
8765                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8766               endif
8767             else
8768 #ifdef MOMENT
8769               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8770 #else
8771               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8772 #endif
8773               if (l.eq.j+1) then
8774                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8775               else
8776                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8777               endif
8778             endif
8779           enddo
8780         enddo
8781       enddo
8782       return
8783       end
8784 c----------------------------------------------------------------------------
8785       double precision function eello_turn6(i,jj,kk)
8786       implicit real*8 (a-h,o-z)
8787       include 'DIMENSIONS'
8788       include 'COMMON.IOUNITS'
8789       include 'COMMON.CHAIN'
8790       include 'COMMON.DERIV'
8791       include 'COMMON.INTERACT'
8792       include 'COMMON.CONTACTS'
8793       include 'COMMON.TORSION'
8794       include 'COMMON.VAR'
8795       include 'COMMON.GEO'
8796       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8797      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8798      &  ggg1(3),ggg2(3)
8799       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8800      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8801 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8802 C           the respective energy moment and not to the cluster cumulant.
8803       s1=0.0d0
8804       s8=0.0d0
8805       s13=0.0d0
8806 c
8807       eello_turn6=0.0d0
8808       j=i+4
8809       k=i+1
8810       l=i+3
8811       iti=itortyp(itype(i))
8812       itk=itortyp(itype(k))
8813       itk1=itortyp(itype(k+1))
8814       itl=itortyp(itype(l))
8815       itj=itortyp(itype(j))
8816 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8817 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8818 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8819 cd        eello6=0.0d0
8820 cd        return
8821 cd      endif
8822 cd      write (iout,*)
8823 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8824 cd     &   ' and',k,l
8825 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8826       do iii=1,2
8827         do kkk=1,5
8828           do lll=1,3
8829             derx_turn(lll,kkk,iii)=0.0d0
8830           enddo
8831         enddo
8832       enddo
8833 cd      eij=1.0d0
8834 cd      ekl=1.0d0
8835 cd      ekont=1.0d0
8836       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8837 cd      eello6_5=0.0d0
8838 cd      write (2,*) 'eello6_5',eello6_5
8839 #ifdef MOMENT
8840       call transpose2(AEA(1,1,1),auxmat(1,1))
8841       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8842       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8843       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8844 #endif
8845       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8846       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8847       s2 = scalar2(b1(1,k),vtemp1(1))
8848 #ifdef MOMENT
8849       call transpose2(AEA(1,1,2),atemp(1,1))
8850       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8851       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8852       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8853 #endif
8854       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8855       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8856       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8857 #ifdef MOMENT
8858       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8859       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8860       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8861       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8862       ss13 = scalar2(b1(1,k),vtemp4(1))
8863       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8864 #endif
8865 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8866 c      s1=0.0d0
8867 c      s2=0.0d0
8868 c      s8=0.0d0
8869 c      s12=0.0d0
8870 c      s13=0.0d0
8871       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8872 C Derivatives in gamma(i+2)
8873       s1d =0.0d0
8874       s8d =0.0d0
8875 #ifdef MOMENT
8876       call transpose2(AEA(1,1,1),auxmatd(1,1))
8877       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8878       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8879       call transpose2(AEAderg(1,1,2),atempd(1,1))
8880       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8881       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8882 #endif
8883       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8884       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8885       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8886 c      s1d=0.0d0
8887 c      s2d=0.0d0
8888 c      s8d=0.0d0
8889 c      s12d=0.0d0
8890 c      s13d=0.0d0
8891       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8892 C Derivatives in gamma(i+3)
8893 #ifdef MOMENT
8894       call transpose2(AEA(1,1,1),auxmatd(1,1))
8895       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8896       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8897       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8898 #endif
8899       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8900       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8901       s2d = scalar2(b1(1,k),vtemp1d(1))
8902 #ifdef MOMENT
8903       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8904       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8905 #endif
8906       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8907 #ifdef MOMENT
8908       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8909       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8910       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8911 #endif
8912 c      s1d=0.0d0
8913 c      s2d=0.0d0
8914 c      s8d=0.0d0
8915 c      s12d=0.0d0
8916 c      s13d=0.0d0
8917 #ifdef MOMENT
8918       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8919      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8920 #else
8921       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8922      &               -0.5d0*ekont*(s2d+s12d)
8923 #endif
8924 C Derivatives in gamma(i+4)
8925       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8926       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8927       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8928 #ifdef MOMENT
8929       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8930       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8931       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8932 #endif
8933 c      s1d=0.0d0
8934 c      s2d=0.0d0
8935 c      s8d=0.0d0
8936 C      s12d=0.0d0
8937 c      s13d=0.0d0
8938 #ifdef MOMENT
8939       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8940 #else
8941       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8942 #endif
8943 C Derivatives in gamma(i+5)
8944 #ifdef MOMENT
8945       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8946       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8947       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8948 #endif
8949       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8950       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8951       s2d = scalar2(b1(1,k),vtemp1d(1))
8952 #ifdef MOMENT
8953       call transpose2(AEA(1,1,2),atempd(1,1))
8954       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8955       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8956 #endif
8957       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8958       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8959 #ifdef MOMENT
8960       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8961       ss13d = scalar2(b1(1,k),vtemp4d(1))
8962       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8963 #endif
8964 c      s1d=0.0d0
8965 c      s2d=0.0d0
8966 c      s8d=0.0d0
8967 c      s12d=0.0d0
8968 c      s13d=0.0d0
8969 #ifdef MOMENT
8970       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8971      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8972 #else
8973       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8974      &               -0.5d0*ekont*(s2d+s12d)
8975 #endif
8976 C Cartesian derivatives
8977       do iii=1,2
8978         do kkk=1,5
8979           do lll=1,3
8980 #ifdef MOMENT
8981             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8982             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8983             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8984 #endif
8985             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8986             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8987      &          vtemp1d(1))
8988             s2d = scalar2(b1(1,k),vtemp1d(1))
8989 #ifdef MOMENT
8990             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8991             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8992             s8d = -(atempd(1,1)+atempd(2,2))*
8993      &           scalar2(cc(1,1,itl),vtemp2(1))
8994 #endif
8995             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8996      &           auxmatd(1,1))
8997             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8998             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8999 c      s1d=0.0d0
9000 c      s2d=0.0d0
9001 c      s8d=0.0d0
9002 c      s12d=0.0d0
9003 c      s13d=0.0d0
9004 #ifdef MOMENT
9005             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9006      &        - 0.5d0*(s1d+s2d)
9007 #else
9008             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9009      &        - 0.5d0*s2d
9010 #endif
9011 #ifdef MOMENT
9012             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9013      &        - 0.5d0*(s8d+s12d)
9014 #else
9015             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9016      &        - 0.5d0*s12d
9017 #endif
9018           enddo
9019         enddo
9020       enddo
9021 #ifdef MOMENT
9022       do kkk=1,5
9023         do lll=1,3
9024           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9025      &      achuj_tempd(1,1))
9026           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9027           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9028           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9029           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9030           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9031      &      vtemp4d(1))
9032           ss13d = scalar2(b1(1,k),vtemp4d(1))
9033           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9034           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9035         enddo
9036       enddo
9037 #endif
9038 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9039 cd     &  16*eel_turn6_num
9040 cd      goto 1112
9041       if (j.lt.nres-1) then
9042         j1=j+1
9043         j2=j-1
9044       else
9045         j1=j-1
9046         j2=j-2
9047       endif
9048       if (l.lt.nres-1) then
9049         l1=l+1
9050         l2=l-1
9051       else
9052         l1=l-1
9053         l2=l-2
9054       endif
9055       do ll=1,3
9056 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9057 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9058 cgrad        ghalf=0.5d0*ggg1(ll)
9059 cd        ghalf=0.0d0
9060         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9061         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9062         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9063      &    +ekont*derx_turn(ll,2,1)
9064         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9065         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9066      &    +ekont*derx_turn(ll,4,1)
9067         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9068         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9069         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9070 cgrad        ghalf=0.5d0*ggg2(ll)
9071 cd        ghalf=0.0d0
9072         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9073      &    +ekont*derx_turn(ll,2,2)
9074         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9075         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9076      &    +ekont*derx_turn(ll,4,2)
9077         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9078         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9079         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9080       enddo
9081 cd      goto 1112
9082 cgrad      do m=i+1,j-1
9083 cgrad        do ll=1,3
9084 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9085 cgrad        enddo
9086 cgrad      enddo
9087 cgrad      do m=k+1,l-1
9088 cgrad        do ll=1,3
9089 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9090 cgrad        enddo
9091 cgrad      enddo
9092 cgrad1112  continue
9093 cgrad      do m=i+2,j2
9094 cgrad        do ll=1,3
9095 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9096 cgrad        enddo
9097 cgrad      enddo
9098 cgrad      do m=k+2,l2
9099 cgrad        do ll=1,3
9100 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9101 cgrad        enddo
9102 cgrad      enddo
9103 cd      do iii=1,nres-3
9104 cd        write (2,*) iii,g_corr6_loc(iii)
9105 cd      enddo
9106       eello_turn6=ekont*eel_turn6
9107 cd      write (2,*) 'ekont',ekont
9108 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9109       return
9110       end
9111
9112 C-----------------------------------------------------------------------------
9113       double precision function scalar(u,v)
9114 !DIR$ INLINEALWAYS scalar
9115 #ifndef OSF
9116 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9117 #endif
9118       implicit none
9119       double precision u(3),v(3)
9120 cd      double precision sc
9121 cd      integer i
9122 cd      sc=0.0d0
9123 cd      do i=1,3
9124 cd        sc=sc+u(i)*v(i)
9125 cd      enddo
9126 cd      scalar=sc
9127
9128       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9129       return
9130       end
9131 crc-------------------------------------------------
9132       SUBROUTINE MATVEC2(A1,V1,V2)
9133 !DIR$ INLINEALWAYS MATVEC2
9134 #ifndef OSF
9135 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9136 #endif
9137       implicit real*8 (a-h,o-z)
9138       include 'DIMENSIONS'
9139       DIMENSION A1(2,2),V1(2),V2(2)
9140 c      DO 1 I=1,2
9141 c        VI=0.0
9142 c        DO 3 K=1,2
9143 c    3     VI=VI+A1(I,K)*V1(K)
9144 c        Vaux(I)=VI
9145 c    1 CONTINUE
9146
9147       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9148       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9149
9150       v2(1)=vaux1
9151       v2(2)=vaux2
9152       END
9153 C---------------------------------------
9154       SUBROUTINE MATMAT2(A1,A2,A3)
9155 #ifndef OSF
9156 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9157 #endif
9158       implicit real*8 (a-h,o-z)
9159       include 'DIMENSIONS'
9160       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9161 c      DIMENSION AI3(2,2)
9162 c        DO  J=1,2
9163 c          A3IJ=0.0
9164 c          DO K=1,2
9165 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9166 c          enddo
9167 c          A3(I,J)=A3IJ
9168 c       enddo
9169 c      enddo
9170
9171       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9172       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9173       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9174       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9175
9176       A3(1,1)=AI3_11
9177       A3(2,1)=AI3_21
9178       A3(1,2)=AI3_12
9179       A3(2,2)=AI3_22
9180       END
9181
9182 c-------------------------------------------------------------------------
9183       double precision function scalar2(u,v)
9184 !DIR$ INLINEALWAYS scalar2
9185       implicit none
9186       double precision u(2),v(2)
9187       double precision sc
9188       integer i
9189       scalar2=u(1)*v(1)+u(2)*v(2)
9190       return
9191       end
9192
9193 C-----------------------------------------------------------------------------
9194
9195       subroutine transpose2(a,at)
9196 !DIR$ INLINEALWAYS transpose2
9197 #ifndef OSF
9198 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9199 #endif
9200       implicit none
9201       double precision a(2,2),at(2,2)
9202       at(1,1)=a(1,1)
9203       at(1,2)=a(2,1)
9204       at(2,1)=a(1,2)
9205       at(2,2)=a(2,2)
9206       return
9207       end
9208 c--------------------------------------------------------------------------
9209       subroutine transpose(n,a,at)
9210       implicit none
9211       integer n,i,j
9212       double precision a(n,n),at(n,n)
9213       do i=1,n
9214         do j=1,n
9215           at(j,i)=a(i,j)
9216         enddo
9217       enddo
9218       return
9219       end
9220 C---------------------------------------------------------------------------
9221       subroutine prodmat3(a1,a2,kk,transp,prod)
9222 !DIR$ INLINEALWAYS prodmat3
9223 #ifndef OSF
9224 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9225 #endif
9226       implicit none
9227       integer i,j
9228       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9229       logical transp
9230 crc      double precision auxmat(2,2),prod_(2,2)
9231
9232       if (transp) then
9233 crc        call transpose2(kk(1,1),auxmat(1,1))
9234 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9235 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9236
9237            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9238      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9239            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9240      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9241            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9242      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9243            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9244      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9245
9246       else
9247 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9248 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9249
9250            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9251      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9252            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9253      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9254            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9255      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9256            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9257      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9258
9259       endif
9260 c      call transpose2(a2(1,1),a2t(1,1))
9261
9262 crc      print *,transp
9263 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9264 crc      print *,((prod(i,j),i=1,2),j=1,2)
9265
9266       return
9267       end
9268