source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #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 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       evdw=0.0D0
1417 ccccc      energy_dec=.false.
1418 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       lprn=.false.
1421 c     if (icall.eq.0) lprn=.false.
1422       ind=0
1423       do i=iatsc_s,iatsc_e
1424         itypi=iabs(itype(i))
1425         if (itypi.eq.ntyp1) cycle
1426         itypi1=iabs(itype(i+1))
1427         xi=c(1,nres+i)
1428         yi=c(2,nres+i)
1429         zi=c(3,nres+i)
1430         dxi=dc_norm(1,nres+i)
1431         dyi=dc_norm(2,nres+i)
1432         dzi=dc_norm(3,nres+i)
1433 c        dsci_inv=dsc_inv(itypi)
1434         dsci_inv=vbld_inv(i+nres)
1435 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1436 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1437 C
1438 C Calculate SC interaction energy.
1439 C
1440         do iint=1,nint_gr(i)
1441           do j=istart(i,iint),iend(i,iint)
1442             ind=ind+1
1443             itypj=iabs(itype(j))
1444             if (itypj.eq.ntyp1) cycle
1445 c            dscj_inv=dsc_inv(itypj)
1446             dscj_inv=vbld_inv(j+nres)
1447 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1448 c     &       1.0d0/vbld(j+nres)
1449 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1450             sig0ij=sigma(itypi,itypj)
1451             chi1=chi(itypi,itypj)
1452             chi2=chi(itypj,itypi)
1453             chi12=chi1*chi2
1454             chip1=chip(itypi)
1455             chip2=chip(itypj)
1456             chip12=chip1*chip2
1457             alf1=alp(itypi)
1458             alf2=alp(itypj)
1459             alf12=0.5D0*(alf1+alf2)
1460 C For diagnostics only!!!
1461 c           chi1=0.0D0
1462 c           chi2=0.0D0
1463 c           chi12=0.0D0
1464 c           chip1=0.0D0
1465 c           chip2=0.0D0
1466 c           chip12=0.0D0
1467 c           alf1=0.0D0
1468 c           alf2=0.0D0
1469 c           alf12=0.0D0
1470             xj=c(1,nres+j)-xi
1471             yj=c(2,nres+j)-yi
1472             zj=c(3,nres+j)-zi
1473             dxj=dc_norm(1,nres+j)
1474             dyj=dc_norm(2,nres+j)
1475             dzj=dc_norm(3,nres+j)
1476 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1477 c            write (iout,*) "j",j," dc_norm",
1478 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480             rij=dsqrt(rrij)
1481 C Calculate angle-dependent terms of energy and contributions to their
1482 C derivatives.
1483             call sc_angular
1484             sigsq=1.0D0/sigsq
1485             sig=sig0ij*dsqrt(sigsq)
1486             rij_shift=1.0D0/rij-sig+sig0ij
1487 c for diagnostics; uncomment
1488 c            rij_shift=1.2*sig0ij
1489 C I hate to put IF's in the loops, but here don't have another choice!!!!
1490             if (rij_shift.le.0.0D0) then
1491               evdw=1.0D20
1492 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1495               return
1496             endif
1497             sigder=-sig*sigsq
1498 c---------------------------------------------------------------
1499             rij_shift=1.0D0/rij_shift
1500             fac=rij_shift**expon
1501             e1=fac*fac*aa(itypi,itypj)
1502             e2=fac*bb(itypi,itypj)
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1507 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1508             evdwij=evdwij*eps2rt*eps3rt
1509             evdw=evdw+evdwij
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1514      &        restyp(itypi),i,restyp(itypj),j,
1515      &        epsi,sigm,chi1,chi2,chip1,chip2,
1516      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1517      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1518      &        evdwij
1519             endif
1520
1521             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1522      &                        'evdw',i,j,evdwij
1523
1524 C Calculate gradient components.
1525             e1=e1*eps1*eps2rt**2*eps3rt**2
1526             fac=-expon*(e1+evdwij)*rij_shift
1527             sigder=fac*sigder
1528             fac=rij*fac
1529 c            fac=0.0d0
1530 C Calculate the radial part of the gradient
1531             gg(1)=xj*fac
1532             gg(2)=yj*fac
1533             gg(3)=zj*fac
1534 C Calculate angular part of the gradient.
1535             call sc_grad
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c      write (iout,*) "Number of loop steps in EGB:",ind
1540 cccc      energy_dec=.false.
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egbv(evdw)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne-Vorobjev potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       common /srutu/ icall
1561       logical lprn
1562       evdw=0.0D0
1563 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1564       evdw=0.0D0
1565       lprn=.false.
1566 c     if (icall.eq.0) lprn=.true.
1567       ind=0
1568       do i=iatsc_s,iatsc_e
1569         itypi=iabs(itype(i))
1570         if (itypi.eq.ntyp1) cycle
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 C
1581 C Calculate SC interaction energy.
1582 C
1583         do iint=1,nint_gr(i)
1584           do j=istart(i,iint),iend(i,iint)
1585             ind=ind+1
1586             itypj=iabs(itype(j))
1587             if (itypj.eq.ntyp1) cycle
1588 c            dscj_inv=dsc_inv(itypj)
1589             dscj_inv=vbld_inv(j+nres)
1590             sig0ij=sigma(itypi,itypj)
1591             r0ij=r0(itypi,itypj)
1592             chi1=chi(itypi,itypj)
1593             chi2=chi(itypj,itypi)
1594             chi12=chi1*chi2
1595             chip1=chip(itypi)
1596             chip2=chip(itypj)
1597             chip12=chip1*chip2
1598             alf1=alp(itypi)
1599             alf2=alp(itypj)
1600             alf12=0.5D0*(alf1+alf2)
1601 C For diagnostics only!!!
1602 c           chi1=0.0D0
1603 c           chi2=0.0D0
1604 c           chi12=0.0D0
1605 c           chip1=0.0D0
1606 c           chip2=0.0D0
1607 c           chip12=0.0D0
1608 c           alf1=0.0D0
1609 c           alf2=0.0D0
1610 c           alf12=0.0D0
1611             xj=c(1,nres+j)-xi
1612             yj=c(2,nres+j)-yi
1613             zj=c(3,nres+j)-zi
1614             dxj=dc_norm(1,nres+j)
1615             dyj=dc_norm(2,nres+j)
1616             dzj=dc_norm(3,nres+j)
1617             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1618             rij=dsqrt(rrij)
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+r0ij
1625 C I hate to put IF's in the loops, but here don't have another choice!!!!
1626             if (rij_shift.le.0.0D0) then
1627               evdw=1.0D20
1628               return
1629             endif
1630             sigder=-sig*sigsq
1631 c---------------------------------------------------------------
1632             rij_shift=1.0D0/rij_shift
1633             fac=rij_shift**expon
1634             e1=fac*fac*aa(itypi,itypj)
1635             e2=fac*bb(itypi,itypj)
1636             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1637             eps2der=evdwij*eps3rt
1638             eps3der=evdwij*eps2rt
1639             fac_augm=rrij**expon
1640             e_augm=augm(itypi,itypj)*fac_augm
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij+e_augm
1643             if (lprn) then
1644             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1645             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647      &        restyp(itypi),i,restyp(itypj),j,
1648      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1649      &        chi1,chi2,chip1,chip2,
1650      &        eps1,eps2rt**2,eps3rt**2,
1651      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1652      &        evdwij+e_augm
1653             endif
1654 C Calculate gradient components.
1655             e1=e1*eps1*eps2rt**2*eps3rt**2
1656             fac=-expon*(e1+evdwij)*rij_shift
1657             sigder=fac*sigder
1658             fac=rij*fac-2*expon*rrij*e_augm
1659 C Calculate the radial part of the gradient
1660             gg(1)=xj*fac
1661             gg(2)=yj*fac
1662             gg(3)=zj*fac
1663 C Calculate angular part of the gradient.
1664             call sc_grad
1665           enddo      ! j
1666         enddo        ! iint
1667       enddo          ! i
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine sc_angular
1671 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1672 C om12. Called by ebp, egb, and egbv.
1673       implicit none
1674       include 'COMMON.CALC'
1675       include 'COMMON.IOUNITS'
1676       erij(1)=xj*rij
1677       erij(2)=yj*rij
1678       erij(3)=zj*rij
1679       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1680       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1681       om12=dxi*dxj+dyi*dyj+dzi*dzj
1682       chiom12=chi12*om12
1683 C Calculate eps1(om12) and its derivative in om12
1684       faceps1=1.0D0-om12*chiom12
1685       faceps1_inv=1.0D0/faceps1
1686       eps1=dsqrt(faceps1_inv)
1687 C Following variable is eps1*deps1/dom12
1688       eps1_om12=faceps1_inv*chiom12
1689 c diagnostics only
1690 c      faceps1_inv=om12
1691 c      eps1=om12
1692 c      eps1_om12=1.0d0
1693 c      write (iout,*) "om12",om12," eps1",eps1
1694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1695 C and om12.
1696       om1om2=om1*om2
1697       chiom1=chi1*om1
1698       chiom2=chi2*om2
1699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1700       sigsq=1.0D0-facsig*faceps1_inv
1701       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1702       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1703       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1704 c diagnostics only
1705 c      sigsq=1.0d0
1706 c      sigsq_om1=0.0d0
1707 c      sigsq_om2=0.0d0
1708 c      sigsq_om12=0.0d0
1709 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1710 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1711 c     &    " eps1",eps1
1712 C Calculate eps2 and its derivatives in om1, om2, and om12.
1713       chipom1=chip1*om1
1714       chipom2=chip2*om2
1715       chipom12=chip12*om12
1716       facp=1.0D0-om12*chipom12
1717       facp_inv=1.0D0/facp
1718       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1719 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1720 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1721 C Following variable is the square root of eps2
1722       eps2rt=1.0D0-facp1*facp_inv
1723 C Following three variables are the derivatives of the square root of eps
1724 C in om1, om2, and om12.
1725       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1726       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1727       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1728 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1729       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1730 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1731 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1732 c     &  " eps2rt_om12",eps2rt_om12
1733 C Calculate whole angle-dependent part of epsilon and contributions
1734 C to its derivatives
1735       return
1736       end
1737 C----------------------------------------------------------------------------
1738       subroutine sc_grad
1739       implicit real*8 (a-h,o-z)
1740       include 'DIMENSIONS'
1741       include 'COMMON.CHAIN'
1742       include 'COMMON.DERIV'
1743       include 'COMMON.CALC'
1744       include 'COMMON.IOUNITS'
1745       double precision dcosom1(3),dcosom2(3)
1746       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1747       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1748       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1749      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1750 c diagnostics only
1751 c      eom1=0.0d0
1752 c      eom2=0.0d0
1753 c      eom12=evdwij*eps1_om12
1754 c end diagnostics
1755 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1756 c     &  " sigder",sigder
1757 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1758 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1759       do k=1,3
1760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1762       enddo
1763       do k=1,3
1764         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1765       enddo
1766 c      write (iout,*) "gg",(gg(k),k=1,3)
1767       do k=1,3
1768         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1769      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1770      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1771         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1772      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1775 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1776 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1777 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1778       enddo
1779 C
1780 C Calculate the components of the gradient in DC and X
1781 C
1782 cgrad      do k=i,j-1
1783 cgrad        do l=1,3
1784 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1785 cgrad        enddo
1786 cgrad      enddo
1787       do l=1,3
1788         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1789         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1790       enddo
1791       return
1792       end
1793 C-----------------------------------------------------------------------
1794       subroutine e_softsphere(evdw)
1795 C
1796 C This subroutine calculates the interaction energy of nonbonded side chains
1797 C assuming the LJ potential of interaction.
1798 C
1799       implicit real*8 (a-h,o-z)
1800       include 'DIMENSIONS'
1801       parameter (accur=1.0d-10)
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.INTERACT'
1808       include 'COMMON.TORSION'
1809       include 'COMMON.SBRIDGE'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CONTACTS'
1813       dimension gg(3)
1814 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823 C
1824 C Calculate SC interaction energy.
1825 C
1826         do iint=1,nint_gr(i)
1827 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1828 cd   &                  'iend=',iend(i,iint)
1829           do j=istart(i,iint),iend(i,iint)
1830             itypj=iabs(itype(j))
1831             if (itypj.eq.ntyp1) cycle
1832             xj=c(1,nres+j)-xi
1833             yj=c(2,nres+j)-yi
1834             zj=c(3,nres+j)-zi
1835             rij=xj*xj+yj*yj+zj*zj
1836 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1837             r0ij=r0(itypi,itypj)
1838             r0ijsq=r0ij*r0ij
1839 c            print *,i,j,r0ij,dsqrt(rij)
1840             if (rij.lt.r0ijsq) then
1841               evdwij=0.25d0*(rij-r0ijsq)**2
1842               fac=rij-r0ijsq
1843             else
1844               evdwij=0.0d0
1845               fac=0.0d0
1846             endif
1847             evdw=evdw+evdwij
1848 C
1849 C Calculate the components of the gradient in DC and X
1850 C
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854             do k=1,3
1855               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1856               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1857               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1858               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1859             enddo
1860 cgrad            do k=i,j-1
1861 cgrad              do l=1,3
1862 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1863 cgrad              enddo
1864 cgrad            enddo
1865           enddo ! j
1866         enddo ! iint
1867       enddo ! i
1868       return
1869       end
1870 C--------------------------------------------------------------------------
1871       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1872      &              eello_turn4)
1873 C
1874 C Soft-sphere potential of p-p interaction
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       include 'COMMON.CONTROL'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.GEO'
1881       include 'COMMON.VAR'
1882       include 'COMMON.LOCAL'
1883       include 'COMMON.CHAIN'
1884       include 'COMMON.DERIV'
1885       include 'COMMON.INTERACT'
1886       include 'COMMON.CONTACTS'
1887       include 'COMMON.TORSION'
1888       include 'COMMON.VECTORS'
1889       include 'COMMON.FFIELD'
1890       dimension ggg(3)
1891 cd      write(iout,*) 'In EELEC_soft_sphere'
1892       ees=0.0D0
1893       evdw1=0.0D0
1894       eel_loc=0.0d0
1895       eello_turn3=0.0d0
1896       eello_turn4=0.0d0
1897       ind=0
1898       do i=iatel_s,iatel_e
1899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1900         dxi=dc(1,i)
1901         dyi=dc(2,i)
1902         dzi=dc(3,i)
1903         xmedi=c(1,i)+0.5d0*dxi
1904         ymedi=c(2,i)+0.5d0*dyi
1905         zmedi=c(3,i)+0.5d0*dzi
1906         num_conti=0
1907 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1908         do j=ielstart(i),ielend(i)
1909           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1910           ind=ind+1
1911           iteli=itel(i)
1912           itelj=itel(j)
1913           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1914           r0ij=rpp(iteli,itelj)
1915           r0ijsq=r0ij*r0ij
1916           dxj=dc(1,j)
1917           dyj=dc(2,j)
1918           dzj=dc(3,j)
1919           xj=c(1,j)+0.5D0*dxj-xmedi
1920           yj=c(2,j)+0.5D0*dyj-ymedi
1921           zj=c(3,j)+0.5D0*dzj-zmedi
1922           rij=xj*xj+yj*yj+zj*zj
1923           if (rij.lt.r0ijsq) then
1924             evdw1ij=0.25d0*(rij-r0ijsq)**2
1925             fac=rij-r0ijsq
1926           else
1927             evdw1ij=0.0d0
1928             fac=0.0d0
1929           endif
1930           evdw1=evdw1+evdw1ij
1931 C
1932 C Calculate contributions to the Cartesian gradient.
1933 C
1934           ggg(1)=fac*xj
1935           ggg(2)=fac*yj
1936           ggg(3)=fac*zj
1937           do k=1,3
1938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1940           enddo
1941 *
1942 * Loop over residues i+1 thru j-1.
1943 *
1944 cgrad          do k=i+1,j-1
1945 cgrad            do l=1,3
1946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1947 cgrad            enddo
1948 cgrad          enddo
1949         enddo ! j
1950       enddo   ! i
1951 cgrad      do i=nnt,nct-1
1952 cgrad        do k=1,3
1953 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1954 cgrad        enddo
1955 cgrad        do j=i+1,nct-1
1956 cgrad          do k=1,3
1957 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1958 cgrad          enddo
1959 cgrad        enddo
1960 cgrad      enddo
1961       return
1962       end
1963 c------------------------------------------------------------------------------
1964       subroutine vec_and_deriv
1965       implicit real*8 (a-h,o-z)
1966       include 'DIMENSIONS'
1967 #ifdef MPI
1968       include 'mpif.h'
1969 #endif
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.VECTORS'
1976       include 'COMMON.SETUP'
1977       include 'COMMON.TIME1'
1978       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1979 C Compute the local reference systems. For reference system (i), the
1980 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1981 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1982 #ifdef PARVEC
1983       do i=ivec_start,ivec_end
1984 #else
1985       do i=1,nres-1
1986 #endif
1987           if (i.eq.nres-1) then
1988 C Case of the last full residue
1989 C Compute the Z-axis
1990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1991             costh=dcos(pi-theta(nres))
1992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1993             do k=1,3
1994               uz(k,i)=fac*uz(k,i)
1995             enddo
1996 C Compute the derivatives of uz
1997             uzder(1,1,1)= 0.0d0
1998             uzder(2,1,1)=-dc_norm(3,i-1)
1999             uzder(3,1,1)= dc_norm(2,i-1)
2000             uzder(1,2,1)= dc_norm(3,i-1)
2001             uzder(2,2,1)= 0.0d0
2002             uzder(3,2,1)=-dc_norm(1,i-1)
2003             uzder(1,3,1)=-dc_norm(2,i-1)
2004             uzder(2,3,1)= dc_norm(1,i-1)
2005             uzder(3,3,1)= 0.0d0
2006             uzder(1,1,2)= 0.0d0
2007             uzder(2,1,2)= dc_norm(3,i)
2008             uzder(3,1,2)=-dc_norm(2,i)
2009             uzder(1,2,2)=-dc_norm(3,i)
2010             uzder(2,2,2)= 0.0d0
2011             uzder(3,2,2)= dc_norm(1,i)
2012             uzder(1,3,2)= dc_norm(2,i)
2013             uzder(2,3,2)=-dc_norm(1,i)
2014             uzder(3,3,2)= 0.0d0
2015 C Compute the Y-axis
2016             facy=fac
2017             do k=1,3
2018               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2019             enddo
2020 C Compute the derivatives of uy
2021             do j=1,3
2022               do k=1,3
2023                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2024      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2025                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2026               enddo
2027               uyder(j,j,1)=uyder(j,j,1)-costh
2028               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2029             enddo
2030             do j=1,2
2031               do k=1,3
2032                 do l=1,3
2033                   uygrad(l,k,j,i)=uyder(l,k,j)
2034                   uzgrad(l,k,j,i)=uzder(l,k,j)
2035                 enddo
2036               enddo
2037             enddo
2038             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2039             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2040             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2041             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2042           else
2043 C Other residues
2044 C Compute the Z-axis
2045             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2046             costh=dcos(pi-theta(i+2))
2047             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2048             do k=1,3
2049               uz(k,i)=fac*uz(k,i)
2050             enddo
2051 C Compute the derivatives of uz
2052             uzder(1,1,1)= 0.0d0
2053             uzder(2,1,1)=-dc_norm(3,i+1)
2054             uzder(3,1,1)= dc_norm(2,i+1)
2055             uzder(1,2,1)= dc_norm(3,i+1)
2056             uzder(2,2,1)= 0.0d0
2057             uzder(3,2,1)=-dc_norm(1,i+1)
2058             uzder(1,3,1)=-dc_norm(2,i+1)
2059             uzder(2,3,1)= dc_norm(1,i+1)
2060             uzder(3,3,1)= 0.0d0
2061             uzder(1,1,2)= 0.0d0
2062             uzder(2,1,2)= dc_norm(3,i)
2063             uzder(3,1,2)=-dc_norm(2,i)
2064             uzder(1,2,2)=-dc_norm(3,i)
2065             uzder(2,2,2)= 0.0d0
2066             uzder(3,2,2)= dc_norm(1,i)
2067             uzder(1,3,2)= dc_norm(2,i)
2068             uzder(2,3,2)=-dc_norm(1,i)
2069             uzder(3,3,2)= 0.0d0
2070 C Compute the Y-axis
2071             facy=fac
2072             do k=1,3
2073               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2074             enddo
2075 C Compute the derivatives of uy
2076             do j=1,3
2077               do k=1,3
2078                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2079      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2080                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2081               enddo
2082               uyder(j,j,1)=uyder(j,j,1)-costh
2083               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2084             enddo
2085             do j=1,2
2086               do k=1,3
2087                 do l=1,3
2088                   uygrad(l,k,j,i)=uyder(l,k,j)
2089                   uzgrad(l,k,j,i)=uzder(l,k,j)
2090                 enddo
2091               enddo
2092             enddo
2093             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2094             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2095             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2096             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2097           endif
2098       enddo
2099       do i=1,nres-1
2100         vbld_inv_temp(1)=vbld_inv(i+1)
2101         if (i.lt.nres-1) then
2102           vbld_inv_temp(2)=vbld_inv(i+2)
2103           else
2104           vbld_inv_temp(2)=vbld_inv(i)
2105           endif
2106         do j=1,2
2107           do k=1,3
2108             do l=1,3
2109               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2110               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2111             enddo
2112           enddo
2113         enddo
2114       enddo
2115 #if defined(PARVEC) && defined(MPI)
2116       if (nfgtasks1.gt.1) then
2117         time00=MPI_Wtime()
2118 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2119 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2120 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2121         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2122      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2123      &   FG_COMM1,IERR)
2124         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2125      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2126      &   FG_COMM1,IERR)
2127         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2128      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2129      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2130         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2131      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2132      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2133         time_gather=time_gather+MPI_Wtime()-time00
2134       endif
2135 c      if (fg_rank.eq.0) then
2136 c        write (iout,*) "Arrays UY and UZ"
2137 c        do i=1,nres-1
2138 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2139 c     &     (uz(k,i),k=1,3)
2140 c        enddo
2141 c      endif
2142 #endif
2143       return
2144       end
2145 C-----------------------------------------------------------------------------
2146       subroutine check_vecgrad
2147       implicit real*8 (a-h,o-z)
2148       include 'DIMENSIONS'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.GEO'
2151       include 'COMMON.VAR'
2152       include 'COMMON.LOCAL'
2153       include 'COMMON.CHAIN'
2154       include 'COMMON.VECTORS'
2155       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2156       dimension uyt(3,maxres),uzt(3,maxres)
2157       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2158       double precision delta /1.0d-7/
2159       call vec_and_deriv
2160 cd      do i=1,nres
2161 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2162 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2163 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2165 cd     &     (dc_norm(if90,i),if90=1,3)
2166 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2167 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2168 cd          write(iout,'(a)')
2169 cd      enddo
2170       do i=1,nres
2171         do j=1,2
2172           do k=1,3
2173             do l=1,3
2174               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2175               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2176             enddo
2177           enddo
2178         enddo
2179       enddo
2180       call vec_and_deriv
2181       do i=1,nres
2182         do j=1,3
2183           uyt(j,i)=uy(j,i)
2184           uzt(j,i)=uz(j,i)
2185         enddo
2186       enddo
2187       do i=1,nres
2188 cd        write (iout,*) 'i=',i
2189         do k=1,3
2190           erij(k)=dc_norm(k,i)
2191         enddo
2192         do j=1,3
2193           do k=1,3
2194             dc_norm(k,i)=erij(k)
2195           enddo
2196           dc_norm(j,i)=dc_norm(j,i)+delta
2197 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2198 c          do k=1,3
2199 c            dc_norm(k,i)=dc_norm(k,i)/fac
2200 c          enddo
2201 c          write (iout,*) (dc_norm(k,i),k=1,3)
2202 c          write (iout,*) (erij(k),k=1,3)
2203           call vec_and_deriv
2204           do k=1,3
2205             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2206             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2207             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2208             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2209           enddo
2210 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2211 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2212 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2213         enddo
2214         do k=1,3
2215           dc_norm(k,i)=erij(k)
2216         enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2219 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2220 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2221 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2222 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2223 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2224 cd          write (iout,'(a)')
2225 cd        enddo
2226       enddo
2227       return
2228       end
2229 C--------------------------------------------------------------------------
2230       subroutine set_matrices
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233 #ifdef MPI
2234       include "mpif.h"
2235       include "COMMON.SETUP"
2236       integer IERR
2237       integer status(MPI_STATUS_SIZE)
2238 #endif
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.GEO'
2241       include 'COMMON.VAR'
2242       include 'COMMON.LOCAL'
2243       include 'COMMON.CHAIN'
2244       include 'COMMON.DERIV'
2245       include 'COMMON.INTERACT'
2246       include 'COMMON.CONTACTS'
2247       include 'COMMON.TORSION'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.FFIELD'
2250       double precision auxvec(2),auxmat(2,2)
2251 C
2252 C Compute the virtual-bond-torsional-angle dependent quantities needed
2253 C to calculate the el-loc multibody terms of various order.
2254 C
2255 c      write(iout,*) 'nphi=',nphi,nres
2256 #ifdef PARMAT
2257       do i=ivec_start+2,ivec_end+2
2258 #else
2259       do i=3,nres+1
2260 #endif
2261 #ifdef NEWCORR
2262         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2263           iti = itortyp(itype(i-2))
2264         else
2265           iti=ntortyp+1
2266         endif
2267 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2268         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2269           iti1 = itortyp(itype(i-1))
2270         else
2271           iti1=ntortyp+1
2272         endif
2273 c        write(iout,*),i
2274         b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0)
2275      &           +bnew1(2,1,iti)*sin(theta(i-1))
2276      &           +bnew1(3,1,iti)*cos(theta(i-1)/2.0)
2277         gtb1(1,i-2)=bnew1(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2278      &             +bnew1(2,1,iti)*cos(theta(i-1))
2279      &             -bnew1(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2280 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2281 c     &*(cos(theta(i)/2.0)
2282         b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0)
2283      &           +bnew2(2,1,iti)*sin(theta(i-1))
2284      &           +bnew2(3,1,iti)*cos(theta(i-1)/2.0)
2285 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2286 c     &*(cos(theta(i)/2.0)
2287         gtb2(1,i-2)=bnew2(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2288      &             +bnew2(2,1,iti)*cos(theta(i-1))
2289      &             -bnew2(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2290 c        if (ggb1(1,i).eq.0.0d0) then
2291 c        write(iout,*) 'i=',i,ggb1(1,i),
2292 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2293 c     &bnew1(2,1,iti)*cos(theta(i)),
2294 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2295 c        endif
2296         b1(2,i-2)=bnew1(1,2,iti)
2297         gtb1(2,i-2)=0.0
2298         b2(2,i-2)=bnew2(1,2,iti)
2299         gtb2(2,i-2)=0.0
2300         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2301         EE(1,2,i-2)=eeold(1,2,iti)
2302         EE(2,1,i-2)=eeold(2,1,iti)
2303         EE(2,2,i-2)=eeold(2,2,iti)
2304         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2305         gtEE(1,2,i-2)=0.0d0
2306         gtEE(2,2,i-2)=0.0d0
2307         gtEE(2,1,i-2)=0.0d0
2308 c        EE(2,2,iti)=0.0d0
2309 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2310 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2311 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2312 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2313        b1tilde(1,i-2)=b1(1,i-2)
2314        b1tilde(2,i-2)=-b1(2,i-2)
2315        b2tilde(1,i-2)=b2(1,i-2)
2316        b2tilde(2,i-2)=-b2(2,i-2)
2317 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2318 c       write (iout,*) 'theta=', theta(i-1)
2319        enddo
2320 #ifdef PARMAT
2321       do i=ivec_start+2,ivec_end+2
2322 #else
2323       do i=3,nres+1
2324 #endif
2325 #endif
2326         if (i .lt. nres+1) then
2327           sin1=dsin(phi(i))
2328           cos1=dcos(phi(i))
2329           sintab(i-2)=sin1
2330           costab(i-2)=cos1
2331           obrot(1,i-2)=cos1
2332           obrot(2,i-2)=sin1
2333           sin2=dsin(2*phi(i))
2334           cos2=dcos(2*phi(i))
2335           sintab2(i-2)=sin2
2336           costab2(i-2)=cos2
2337           obrot2(1,i-2)=cos2
2338           obrot2(2,i-2)=sin2
2339           Ug(1,1,i-2)=-cos1
2340           Ug(1,2,i-2)=-sin1
2341           Ug(2,1,i-2)=-sin1
2342           Ug(2,2,i-2)= cos1
2343           Ug2(1,1,i-2)=-cos2
2344           Ug2(1,2,i-2)=-sin2
2345           Ug2(2,1,i-2)=-sin2
2346           Ug2(2,2,i-2)= cos2
2347         else
2348           costab(i-2)=1.0d0
2349           sintab(i-2)=0.0d0
2350           obrot(1,i-2)=1.0d0
2351           obrot(2,i-2)=0.0d0
2352           obrot2(1,i-2)=0.0d0
2353           obrot2(2,i-2)=0.0d0
2354           Ug(1,1,i-2)=1.0d0
2355           Ug(1,2,i-2)=0.0d0
2356           Ug(2,1,i-2)=0.0d0
2357           Ug(2,2,i-2)=1.0d0
2358           Ug2(1,1,i-2)=0.0d0
2359           Ug2(1,2,i-2)=0.0d0
2360           Ug2(2,1,i-2)=0.0d0
2361           Ug2(2,2,i-2)=0.0d0
2362         endif
2363         if (i .gt. 3 .and. i .lt. nres+1) then
2364           obrot_der(1,i-2)=-sin1
2365           obrot_der(2,i-2)= cos1
2366           Ugder(1,1,i-2)= sin1
2367           Ugder(1,2,i-2)=-cos1
2368           Ugder(2,1,i-2)=-cos1
2369           Ugder(2,2,i-2)=-sin1
2370           dwacos2=cos2+cos2
2371           dwasin2=sin2+sin2
2372           obrot2_der(1,i-2)=-dwasin2
2373           obrot2_der(2,i-2)= dwacos2
2374           Ug2der(1,1,i-2)= dwasin2
2375           Ug2der(1,2,i-2)=-dwacos2
2376           Ug2der(2,1,i-2)=-dwacos2
2377           Ug2der(2,2,i-2)=-dwasin2
2378         else
2379           obrot_der(1,i-2)=0.0d0
2380           obrot_der(2,i-2)=0.0d0
2381           Ugder(1,1,i-2)=0.0d0
2382           Ugder(1,2,i-2)=0.0d0
2383           Ugder(2,1,i-2)=0.0d0
2384           Ugder(2,2,i-2)=0.0d0
2385           obrot2_der(1,i-2)=0.0d0
2386           obrot2_der(2,i-2)=0.0d0
2387           Ug2der(1,1,i-2)=0.0d0
2388           Ug2der(1,2,i-2)=0.0d0
2389           Ug2der(2,1,i-2)=0.0d0
2390           Ug2der(2,2,i-2)=0.0d0
2391         endif
2392 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2393         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2394           iti = itortyp(itype(i-2))
2395         else
2396           iti=ntortyp+1
2397         endif
2398 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2399         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2400           iti1 = itortyp(itype(i-1))
2401         else
2402           iti1=ntortyp+1
2403         endif
2404 cd        write (iout,*) '*******i',i,' iti1',iti
2405 cd        write (iout,*) 'b1',b1(:,iti)
2406 cd        write (iout,*) 'b2',b2(:,iti)
2407 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2408 c        if (i .gt. iatel_s+2) then
2409         if (i .gt. nnt+2) then
2410           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2411 #ifdef NEWCORR
2412           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2413 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2414 #endif
2415 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2416 c     &    EE(1,2,iti),EE(2,2,iti)
2417           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2418           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2419 c          write(iout,*) "Macierz EUG",
2420 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2421 c     &    eug(2,2,i-2)
2422           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2423      &    then
2424           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2425           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2426           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2427           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2428           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2429           endif
2430         else
2431           do k=1,2
2432             Ub2(k,i-2)=0.0d0
2433             Ctobr(k,i-2)=0.0d0
2434             Dtobr2(k,i-2)=0.0d0
2435             do l=1,2
2436               EUg(l,k,i-2)=0.0d0
2437               CUg(l,k,i-2)=0.0d0
2438               DUg(l,k,i-2)=0.0d0
2439               DtUg2(l,k,i-2)=0.0d0
2440             enddo
2441           enddo
2442         endif
2443         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2444         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2445         do k=1,2
2446           muder(k,i-2)=Ub2der(k,i-2)
2447         enddo
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           if (itype(i-1).le.ntyp) then
2451             iti1 = itortyp(itype(i-1))
2452           else
2453             iti1=ntortyp+1
2454           endif
2455         else
2456           iti1=ntortyp+1
2457         endif
2458         do k=1,2
2459           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2460         enddo
2461 cd        write (iout,*) 'mu ',mu(:,i-2)
2462 cd        write (iout,*) 'mu1',mu1(:,i-2)
2463 cd        write (iout,*) 'mu2',mu2(:,i-2)
2464         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2465      &  then
2466         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2467         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2468         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2469         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2470         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2471 C Vectors and matrices dependent on a single virtual-bond dihedral.
2472         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2473         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2474         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2475         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2476         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2477         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2478         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2479         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2480         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2481         endif
2482       enddo
2483 C Matrices dependent on two consecutive virtual-bond dihedrals.
2484 C The order of matrices is from left to right.
2485       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2486      &then
2487 c      do i=max0(ivec_start,2),ivec_end
2488       do i=2,nres-1
2489         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2490         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2491         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2492         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2493         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2494         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2495         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2496         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2497       enddo
2498       endif
2499 #if defined(MPI) && defined(PARMAT)
2500 #ifdef DEBUG
2501 c      if (fg_rank.eq.0) then
2502         write (iout,*) "Arrays UG and UGDER before GATHER"
2503         do i=1,nres-1
2504           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2505      &     ((ug(l,k,i),l=1,2),k=1,2),
2506      &     ((ugder(l,k,i),l=1,2),k=1,2)
2507         enddo
2508         write (iout,*) "Arrays UG2 and UG2DER"
2509         do i=1,nres-1
2510           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2511      &     ((ug2(l,k,i),l=1,2),k=1,2),
2512      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2513         enddo
2514         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2515         do i=1,nres-1
2516           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2517      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2518      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2519         enddo
2520         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2521         do i=1,nres-1
2522           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2523      &     costab(i),sintab(i),costab2(i),sintab2(i)
2524         enddo
2525         write (iout,*) "Array MUDER"
2526         do i=1,nres-1
2527           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2528         enddo
2529 c      endif
2530 #endif
2531       if (nfgtasks.gt.1) then
2532         time00=MPI_Wtime()
2533 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2534 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2535 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2536 #ifdef MATGATHER
2537         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2538      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2539      &   FG_COMM1,IERR)
2540         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2544      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2547      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2548      &   FG_COMM1,IERR)
2549         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2550      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2551      &   FG_COMM1,IERR)
2552         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2556      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2557      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2558         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2559      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2560      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2561         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2562      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2563      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2564         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2565      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2566      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2567         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2568      &  then
2569         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2570      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2571      &   FG_COMM1,IERR)
2572         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2573      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2574      &   FG_COMM1,IERR)
2575         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2576      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2577      &   FG_COMM1,IERR)
2578        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2579      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2580      &   FG_COMM1,IERR)
2581         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2582      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2583      &   FG_COMM1,IERR)
2584         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2585      &   ivec_count(fg_rank1),
2586      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2587      &   FG_COMM1,IERR)
2588         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2589      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2590      &   FG_COMM1,IERR)
2591         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2592      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2593      &   FG_COMM1,IERR)
2594         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2595      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2596      &   FG_COMM1,IERR)
2597         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2598      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2601      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2605      &   FG_COMM1,IERR)
2606         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2610      &   ivec_count(fg_rank1),
2611      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2612      &   FG_COMM1,IERR)
2613         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2614      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2615      &   FG_COMM1,IERR)
2616        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2617      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2618      &   FG_COMM1,IERR)
2619         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2620      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2621      &   FG_COMM1,IERR)
2622        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2623      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2624      &   FG_COMM1,IERR)
2625         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2626      &   ivec_count(fg_rank1),
2627      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2628      &   FG_COMM1,IERR)
2629         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2630      &   ivec_count(fg_rank1),
2631      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2632      &   FG_COMM1,IERR)
2633         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2634      &   ivec_count(fg_rank1),
2635      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2636      &   MPI_MAT2,FG_COMM1,IERR)
2637         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2638      &   ivec_count(fg_rank1),
2639      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2640      &   MPI_MAT2,FG_COMM1,IERR)
2641         endif
2642 #else
2643 c Passes matrix info through the ring
2644       isend=fg_rank1
2645       irecv=fg_rank1-1
2646       if (irecv.lt.0) irecv=nfgtasks1-1
2647       iprev=irecv
2648       inext=fg_rank1+1
2649       if (inext.ge.nfgtasks1) inext=0
2650       do i=1,nfgtasks1-1
2651 c        write (iout,*) "isend",isend," irecv",irecv
2652 c        call flush(iout)
2653         lensend=lentyp(isend)
2654         lenrecv=lentyp(irecv)
2655 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2656 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2657 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2658 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2659 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2660 c        write (iout,*) "Gather ROTAT1"
2661 c        call flush(iout)
2662 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2663 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2664 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2665 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2666 c        write (iout,*) "Gather ROTAT2"
2667 c        call flush(iout)
2668         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2669      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2670      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2671      &   iprev,4400+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather ROTAT_OLD"
2673 c        call flush(iout)
2674         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2675      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2676      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2677      &   iprev,5500+irecv,FG_COMM,status,IERR)
2678 c        write (iout,*) "Gather PRECOMP11"
2679 c        call flush(iout)
2680         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2681      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2682      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2683      &   iprev,6600+irecv,FG_COMM,status,IERR)
2684 c        write (iout,*) "Gather PRECOMP12"
2685 c        call flush(iout)
2686         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2687      &  then
2688         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2689      &   MPI_ROTAT2(lensend),inext,7700+isend,
2690      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2691      &   iprev,7700+irecv,FG_COMM,status,IERR)
2692 c        write (iout,*) "Gather PRECOMP21"
2693 c        call flush(iout)
2694         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2695      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2696      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2697      &   iprev,8800+irecv,FG_COMM,status,IERR)
2698 c        write (iout,*) "Gather PRECOMP22"
2699 c        call flush(iout)
2700         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2701      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2702      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2703      &   MPI_PRECOMP23(lenrecv),
2704      &   iprev,9900+irecv,FG_COMM,status,IERR)
2705 c        write (iout,*) "Gather PRECOMP23"
2706 c        call flush(iout)
2707         endif
2708         isend=irecv
2709         irecv=irecv-1
2710         if (irecv.lt.0) irecv=nfgtasks1-1
2711       enddo
2712 #endif
2713         time_gather=time_gather+MPI_Wtime()-time00
2714       endif
2715 #ifdef DEBUG
2716 c      if (fg_rank.eq.0) then
2717         write (iout,*) "Arrays UG and UGDER"
2718         do i=1,nres-1
2719           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2720      &     ((ug(l,k,i),l=1,2),k=1,2),
2721      &     ((ugder(l,k,i),l=1,2),k=1,2)
2722         enddo
2723         write (iout,*) "Arrays UG2 and UG2DER"
2724         do i=1,nres-1
2725           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2726      &     ((ug2(l,k,i),l=1,2),k=1,2),
2727      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2728         enddo
2729         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2730         do i=1,nres-1
2731           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2732      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2733      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2734         enddo
2735         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2736         do i=1,nres-1
2737           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2738      &     costab(i),sintab(i),costab2(i),sintab2(i)
2739         enddo
2740         write (iout,*) "Array MUDER"
2741         do i=1,nres-1
2742           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2743         enddo
2744 c      endif
2745 #endif
2746 #endif
2747 cd      do i=1,nres
2748 cd        iti = itortyp(itype(i))
2749 cd        write (iout,*) i
2750 cd        do j=1,2
2751 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2752 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2753 cd        enddo
2754 cd      enddo
2755       return
2756       end
2757 C--------------------------------------------------------------------------
2758       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2759 C
2760 C This subroutine calculates the average interaction energy and its gradient
2761 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2762 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2763 C The potential depends both on the distance of peptide-group centers and on
2764 C the orientation of the CA-CA virtual bonds.
2765 C
2766       implicit real*8 (a-h,o-z)
2767 #ifdef MPI
2768       include 'mpif.h'
2769 #endif
2770       include 'DIMENSIONS'
2771       include 'COMMON.CONTROL'
2772       include 'COMMON.SETUP'
2773       include 'COMMON.IOUNITS'
2774       include 'COMMON.GEO'
2775       include 'COMMON.VAR'
2776       include 'COMMON.LOCAL'
2777       include 'COMMON.CHAIN'
2778       include 'COMMON.DERIV'
2779       include 'COMMON.INTERACT'
2780       include 'COMMON.CONTACTS'
2781       include 'COMMON.TORSION'
2782       include 'COMMON.VECTORS'
2783       include 'COMMON.FFIELD'
2784       include 'COMMON.TIME1'
2785       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2786      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2787       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2788      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2789       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2790      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2791      &    num_conti,j1,j2
2792 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2793 #ifdef MOMENT
2794       double precision scal_el /1.0d0/
2795 #else
2796       double precision scal_el /0.5d0/
2797 #endif
2798 C 12/13/98
2799 C 13-go grudnia roku pamietnego...
2800       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2801      &                   0.0d0,1.0d0,0.0d0,
2802      &                   0.0d0,0.0d0,1.0d0/
2803 cd      write(iout,*) 'In EELEC'
2804 cd      do i=1,nloctyp
2805 cd        write(iout,*) 'Type',i
2806 cd        write(iout,*) 'B1',B1(:,i)
2807 cd        write(iout,*) 'B2',B2(:,i)
2808 cd        write(iout,*) 'CC',CC(:,:,i)
2809 cd        write(iout,*) 'DD',DD(:,:,i)
2810 cd        write(iout,*) 'EE',EE(:,:,i)
2811 cd      enddo
2812 cd      call check_vecgrad
2813 cd      stop
2814       if (icheckgrad.eq.1) then
2815         do i=1,nres-1
2816           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2817           do k=1,3
2818             dc_norm(k,i)=dc(k,i)*fac
2819           enddo
2820 c          write (iout,*) 'i',i,' fac',fac
2821         enddo
2822       endif
2823       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2824      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2825      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2826 c        call vec_and_deriv
2827 #ifdef TIMING
2828         time01=MPI_Wtime()
2829 #endif
2830         call set_matrices
2831 #ifdef TIMING
2832         time_mat=time_mat+MPI_Wtime()-time01
2833 #endif
2834       endif
2835 cd      do i=1,nres-1
2836 cd        write (iout,*) 'i=',i
2837 cd        do k=1,3
2838 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2839 cd        enddo
2840 cd        do k=1,3
2841 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2842 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2843 cd        enddo
2844 cd      enddo
2845       t_eelecij=0.0d0
2846       ees=0.0D0
2847       evdw1=0.0D0
2848       eel_loc=0.0d0
2849       eello_turn3=0.0d0
2850       eello_turn4=0.0d0
2851       ind=0
2852       do i=1,nres
2853         num_cont_hb(i)=0
2854       enddo
2855 cd      print '(a)','Enter EELEC'
2856 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2857       do i=1,nres
2858         gel_loc_loc(i)=0.0d0
2859         gcorr_loc(i)=0.0d0
2860       enddo
2861 c
2862 c
2863 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2864 C
2865 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2866 C
2867       do i=iturn3_start,iturn3_end
2868         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2869      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2870         dxi=dc(1,i)
2871         dyi=dc(2,i)
2872         dzi=dc(3,i)
2873         dx_normi=dc_norm(1,i)
2874         dy_normi=dc_norm(2,i)
2875         dz_normi=dc_norm(3,i)
2876         xmedi=c(1,i)+0.5d0*dxi
2877         ymedi=c(2,i)+0.5d0*dyi
2878         zmedi=c(3,i)+0.5d0*dzi
2879         num_conti=0
2880         call eelecij(i,i+2,ees,evdw1,eel_loc)
2881         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2882         num_cont_hb(i)=num_conti
2883       enddo
2884       do i=iturn4_start,iturn4_end
2885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2886      &    .or. itype(i+3).eq.ntyp1
2887      &    .or. itype(i+4).eq.ntyp1) cycle
2888         dxi=dc(1,i)
2889         dyi=dc(2,i)
2890         dzi=dc(3,i)
2891         dx_normi=dc_norm(1,i)
2892         dy_normi=dc_norm(2,i)
2893         dz_normi=dc_norm(3,i)
2894         xmedi=c(1,i)+0.5d0*dxi
2895         ymedi=c(2,i)+0.5d0*dyi
2896         zmedi=c(3,i)+0.5d0*dzi
2897         num_conti=num_cont_hb(i)
2898 c        write(iout,*) "JESTEM W PETLI"
2899         call eelecij(i,i+3,ees,evdw1,eel_loc)
2900         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2901      &   call eturn4(i,eello_turn4)
2902         num_cont_hb(i)=num_conti
2903       enddo   ! i
2904 c
2905 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2906 c
2907       do i=iatel_s,iatel_e
2908 c       do i=7,7
2909         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2910         dxi=dc(1,i)
2911         dyi=dc(2,i)
2912         dzi=dc(3,i)
2913         dx_normi=dc_norm(1,i)
2914         dy_normi=dc_norm(2,i)
2915         dz_normi=dc_norm(3,i)
2916         xmedi=c(1,i)+0.5d0*dxi
2917         ymedi=c(2,i)+0.5d0*dyi
2918         zmedi=c(3,i)+0.5d0*dzi
2919 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2920         num_conti=num_cont_hb(i)
2921         do j=ielstart(i),ielend(i)
2922 c         do j=13,13
2923 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2924           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2925           call eelecij(i,j,ees,evdw1,eel_loc)
2926         enddo ! j
2927         num_cont_hb(i)=num_conti
2928       enddo   ! i
2929 c      write (iout,*) "Number of loop steps in EELEC:",ind
2930 cd      do i=1,nres
2931 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2932 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2933 cd      enddo
2934 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2935 ccc      eel_loc=eel_loc+eello_turn3
2936 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2937       return
2938       end
2939 C-------------------------------------------------------------------------------
2940       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2941       implicit real*8 (a-h,o-z)
2942       include 'DIMENSIONS'
2943 #ifdef MPI
2944       include "mpif.h"
2945 #endif
2946       include 'COMMON.CONTROL'
2947       include 'COMMON.IOUNITS'
2948       include 'COMMON.GEO'
2949       include 'COMMON.VAR'
2950       include 'COMMON.LOCAL'
2951       include 'COMMON.CHAIN'
2952       include 'COMMON.DERIV'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.CONTACTS'
2955       include 'COMMON.TORSION'
2956       include 'COMMON.VECTORS'
2957       include 'COMMON.FFIELD'
2958       include 'COMMON.TIME1'
2959       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2960      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2961       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2962      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2963      &    gmuij2(4),gmuji2(4)
2964       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2965      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2966      &    num_conti,j1,j2
2967 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2968 #ifdef MOMENT
2969       double precision scal_el /1.0d0/
2970 #else
2971       double precision scal_el /0.5d0/
2972 #endif
2973 C 12/13/98
2974 C 13-go grudnia roku pamietnego...
2975       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2976      &                   0.0d0,1.0d0,0.0d0,
2977      &                   0.0d0,0.0d0,1.0d0/
2978 c          time00=MPI_Wtime()
2979 cd      write (iout,*) "eelecij",i,j
2980 c          ind=ind+1
2981           iteli=itel(i)
2982           itelj=itel(j)
2983           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2984           aaa=app(iteli,itelj)
2985           bbb=bpp(iteli,itelj)
2986           ael6i=ael6(iteli,itelj)
2987           ael3i=ael3(iteli,itelj)
2988           dxj=dc(1,j)
2989           dyj=dc(2,j)
2990           dzj=dc(3,j)
2991           dx_normj=dc_norm(1,j)
2992           dy_normj=dc_norm(2,j)
2993           dz_normj=dc_norm(3,j)
2994           xj=c(1,j)+0.5D0*dxj-xmedi
2995           yj=c(2,j)+0.5D0*dyj-ymedi
2996           zj=c(3,j)+0.5D0*dzj-zmedi
2997           rij=xj*xj+yj*yj+zj*zj
2998           rrmij=1.0D0/rij
2999           rij=dsqrt(rij)
3000           rmij=1.0D0/rij
3001           r3ij=rrmij*rmij
3002           r6ij=r3ij*r3ij
3003           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3004           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3005           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3006           fac=cosa-3.0D0*cosb*cosg
3007           ev1=aaa*r6ij*r6ij
3008 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3009           if (j.eq.i+2) ev1=scal_el*ev1
3010           ev2=bbb*r6ij
3011           fac3=ael6i*r6ij
3012           fac4=ael3i*r3ij
3013           evdwij=ev1+ev2
3014           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3015           el2=fac4*fac
3016           eesij=el1+el2
3017 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3018           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3019           ees=ees+eesij
3020           evdw1=evdw1+evdwij
3021 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3022 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3023 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3024 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3025
3026           if (energy_dec) then
3027               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3028      &'evdw1',i,j,evdwij
3029      &,iteli,itelj,aaa,evdw1
3030               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3031           endif
3032
3033 C
3034 C Calculate contributions to the Cartesian gradient.
3035 C
3036 #ifdef SPLITELE
3037           facvdw=-6*rrmij*(ev1+evdwij)
3038           facel=-3*rrmij*(el1+eesij)
3039           fac1=fac
3040           erij(1)=xj*rmij
3041           erij(2)=yj*rmij
3042           erij(3)=zj*rmij
3043 *
3044 * Radial derivatives. First process both termini of the fragment (i,j)
3045 *
3046           ggg(1)=facel*xj
3047           ggg(2)=facel*yj
3048           ggg(3)=facel*zj
3049 c          do k=1,3
3050 c            ghalf=0.5D0*ggg(k)
3051 c            gelc(k,i)=gelc(k,i)+ghalf
3052 c            gelc(k,j)=gelc(k,j)+ghalf
3053 c          enddo
3054 c 9/28/08 AL Gradient compotents will be summed only at the end
3055           do k=1,3
3056             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3057             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3058           enddo
3059 *
3060 * Loop over residues i+1 thru j-1.
3061 *
3062 cgrad          do k=i+1,j-1
3063 cgrad            do l=1,3
3064 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3065 cgrad            enddo
3066 cgrad          enddo
3067           ggg(1)=facvdw*xj
3068           ggg(2)=facvdw*yj
3069           ggg(3)=facvdw*zj
3070 c          do k=1,3
3071 c            ghalf=0.5D0*ggg(k)
3072 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3073 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3074 c          enddo
3075 c 9/28/08 AL Gradient compotents will be summed only at the end
3076           do k=1,3
3077             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3078             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3079           enddo
3080 *
3081 * Loop over residues i+1 thru j-1.
3082 *
3083 cgrad          do k=i+1,j-1
3084 cgrad            do l=1,3
3085 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3086 cgrad            enddo
3087 cgrad          enddo
3088 #else
3089           facvdw=ev1+evdwij
3090           facel=el1+eesij
3091           fac1=fac
3092           fac=-3*rrmij*(facvdw+facvdw+facel)
3093           erij(1)=xj*rmij
3094           erij(2)=yj*rmij
3095           erij(3)=zj*rmij
3096 *
3097 * Radial derivatives. First process both termini of the fragment (i,j)
3098 *
3099           ggg(1)=fac*xj
3100           ggg(2)=fac*yj
3101           ggg(3)=fac*zj
3102 c          do k=1,3
3103 c            ghalf=0.5D0*ggg(k)
3104 c            gelc(k,i)=gelc(k,i)+ghalf
3105 c            gelc(k,j)=gelc(k,j)+ghalf
3106 c          enddo
3107 c 9/28/08 AL Gradient compotents will be summed only at the end
3108           do k=1,3
3109             gelc_long(k,j)=gelc(k,j)+ggg(k)
3110             gelc_long(k,i)=gelc(k,i)-ggg(k)
3111           enddo
3112 *
3113 * Loop over residues i+1 thru j-1.
3114 *
3115 cgrad          do k=i+1,j-1
3116 cgrad            do l=1,3
3117 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3118 cgrad            enddo
3119 cgrad          enddo
3120 c 9/28/08 AL Gradient compotents will be summed only at the end
3121           ggg(1)=facvdw*xj
3122           ggg(2)=facvdw*yj
3123           ggg(3)=facvdw*zj
3124           do k=1,3
3125             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3126             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3127           enddo
3128 #endif
3129 *
3130 * Angular part
3131 *
3132           ecosa=2.0D0*fac3*fac1+fac4
3133           fac4=-3.0D0*fac4
3134           fac3=-6.0D0*fac3
3135           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3136           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3137           do k=1,3
3138             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3139             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3140           enddo
3141 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3142 cd   &          (dcosg(k),k=1,3)
3143           do k=1,3
3144             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3145           enddo
3146 c          do k=1,3
3147 c            ghalf=0.5D0*ggg(k)
3148 c            gelc(k,i)=gelc(k,i)+ghalf
3149 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3150 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3151 c            gelc(k,j)=gelc(k,j)+ghalf
3152 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3153 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3154 c          enddo
3155 cgrad          do k=i+1,j-1
3156 cgrad            do l=1,3
3157 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3158 cgrad            enddo
3159 cgrad          enddo
3160           do k=1,3
3161             gelc(k,i)=gelc(k,i)
3162      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3163      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3164             gelc(k,j)=gelc(k,j)
3165      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3166      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3167             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3168             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3169           enddo
3170           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3171      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3172      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3173 C
3174 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3175 C   energy of a peptide unit is assumed in the form of a second-order
3176 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3177 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3178 C   are computed for EVERY pair of non-contiguous peptide groups.
3179 C
3180
3181           if (j.lt.nres-1) then
3182             j1=j+1
3183             j2=j-1
3184           else
3185             j1=j-1
3186             j2=j-2
3187           endif
3188           kkk=0
3189           lll=0
3190           do k=1,2
3191             do l=1,2
3192               kkk=kkk+1
3193               muij(kkk)=mu(k,i)*mu(l,j)
3194 #ifdef NEWCORR
3195              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3196 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(k,i),k,i
3197              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3198              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3199 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(l,j),l,j
3200              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3201 #endif
3202             enddo
3203           enddo
3204 cd         write (iout,*) 'EELEC: i',i,' j',j
3205 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3206 cd          write(iout,*) 'muij',muij
3207           ury=scalar(uy(1,i),erij)
3208           urz=scalar(uz(1,i),erij)
3209           vry=scalar(uy(1,j),erij)
3210           vrz=scalar(uz(1,j),erij)
3211           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3212           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3213           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3214           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3215           fac=dsqrt(-ael6i)*r3ij
3216           a22=a22*fac
3217           a23=a23*fac
3218           a32=a32*fac
3219           a33=a33*fac
3220 cd          write (iout,'(4i5,4f10.5)')
3221 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3222 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3223 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3224 cd     &      uy(:,j),uz(:,j)
3225 cd          write (iout,'(4f10.5)')
3226 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3227 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3228 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3229 cd           write (iout,'(9f10.5/)')
3230 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3231 C Derivatives of the elements of A in virtual-bond vectors
3232           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3233           do k=1,3
3234             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3235             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3236             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3237             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3238             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3239             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3240             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3241             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3242             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3243             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3244             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3245             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3246           enddo
3247 C Compute radial contributions to the gradient
3248           facr=-3.0d0*rrmij
3249           a22der=a22*facr
3250           a23der=a23*facr
3251           a32der=a32*facr
3252           a33der=a33*facr
3253           agg(1,1)=a22der*xj
3254           agg(2,1)=a22der*yj
3255           agg(3,1)=a22der*zj
3256           agg(1,2)=a23der*xj
3257           agg(2,2)=a23der*yj
3258           agg(3,2)=a23der*zj
3259           agg(1,3)=a32der*xj
3260           agg(2,3)=a32der*yj
3261           agg(3,3)=a32der*zj
3262           agg(1,4)=a33der*xj
3263           agg(2,4)=a33der*yj
3264           agg(3,4)=a33der*zj
3265 C Add the contributions coming from er
3266           fac3=-3.0d0*fac
3267           do k=1,3
3268             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3269             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3270             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3271             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3272           enddo
3273           do k=1,3
3274 C Derivatives in DC(i)
3275 cgrad            ghalf1=0.5d0*agg(k,1)
3276 cgrad            ghalf2=0.5d0*agg(k,2)
3277 cgrad            ghalf3=0.5d0*agg(k,3)
3278 cgrad            ghalf4=0.5d0*agg(k,4)
3279             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3280      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3281             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3282      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3283             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3284      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3285             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3286      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3287 C Derivatives in DC(i+1)
3288             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3289      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3290             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3291      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3292             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3293      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3294             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3295      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3296 C Derivatives in DC(j)
3297             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3298      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3299             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3300      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3301             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3302      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3303             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3304      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3305 C Derivatives in DC(j+1) or DC(nres-1)
3306             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3307      &      -3.0d0*vryg(k,3)*ury)
3308             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3309      &      -3.0d0*vrzg(k,3)*ury)
3310             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3311      &      -3.0d0*vryg(k,3)*urz)
3312             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3313      &      -3.0d0*vrzg(k,3)*urz)
3314 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3315 cgrad              do l=1,4
3316 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3317 cgrad              enddo
3318 cgrad            endif
3319           enddo
3320           acipa(1,1)=a22
3321           acipa(1,2)=a23
3322           acipa(2,1)=a32
3323           acipa(2,2)=a33
3324           a22=-a22
3325           a23=-a23
3326           do l=1,2
3327             do k=1,3
3328               agg(k,l)=-agg(k,l)
3329               aggi(k,l)=-aggi(k,l)
3330               aggi1(k,l)=-aggi1(k,l)
3331               aggj(k,l)=-aggj(k,l)
3332               aggj1(k,l)=-aggj1(k,l)
3333             enddo
3334           enddo
3335           if (j.lt.nres-1) then
3336             a22=-a22
3337             a32=-a32
3338             do l=1,3,2
3339               do k=1,3
3340                 agg(k,l)=-agg(k,l)
3341                 aggi(k,l)=-aggi(k,l)
3342                 aggi1(k,l)=-aggi1(k,l)
3343                 aggj(k,l)=-aggj(k,l)
3344                 aggj1(k,l)=-aggj1(k,l)
3345               enddo
3346             enddo
3347           else
3348             a22=-a22
3349             a23=-a23
3350             a32=-a32
3351             a33=-a33
3352             do l=1,4
3353               do k=1,3
3354                 agg(k,l)=-agg(k,l)
3355                 aggi(k,l)=-aggi(k,l)
3356                 aggi1(k,l)=-aggi1(k,l)
3357                 aggj(k,l)=-aggj(k,l)
3358                 aggj1(k,l)=-aggj1(k,l)
3359               enddo
3360             enddo
3361           endif
3362           ENDIF ! WCORR
3363           IF (wel_loc.gt.0.0d0) THEN
3364 c           if ((i.eq.8).and.(j.eq.14)) then
3365 C Contribution to the local-electrostatic energy coming from the i-j pair
3366           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3367      &     +a33*muij(4)
3368 C Calculate patrial derivative for theta angle
3369 #ifdef NEWCORR
3370          geel_loc_ij=a22*gmuij1(1)
3371      &     +a23*gmuij1(2)
3372      &     +a32*gmuij1(3)
3373      &     +a33*gmuij1(4)
3374 c         write(iout,*) "derivative over thatai"
3375 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3376 c     &   a33*gmuij1(4)
3377          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3378      &      geel_loc_ij*wel_loc
3379 c         write(iout,*) "derivative over thatai-1"
3380 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3381 c     &   a33*gmuij2(4)
3382          geel_loc_ij=a22*gmuij2(1)+a23*gmuij2(2)+a32*gmuij2(3)
3383      &     +a33*gmuij2(4)
3384          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3385      &      geel_loc_ij*wel_loc
3386          geel_loc_ji=a22*gmuji1(1)+a23*gmuji1(2)+a32*gmuji1(3)
3387      &     +a33*gmuji1(4)
3388 c         write(iout,*) "derivative over thataj"
3389 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3390 c     &   a33*gmuji1(4)
3391
3392          gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3393      &      geel_loc_ji*wel_loc
3394          geel_loc_ji=a22*gmuji2(1)+a23*gmuji2(2)+a32*gmuji2(3)
3395      &     +a33*gmuji2(4)
3396 c         write(iout,*) "derivative over thataj-1"
3397 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3398 c     &   a33*gmuji2(4)
3399          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3400      &      geel_loc_ji*wel_loc
3401 #endif
3402 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3403
3404           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3405      &            'eelloc',i,j,eel_loc_ij
3406 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3407
3408           eel_loc=eel_loc+eel_loc_ij
3409 C Partial derivatives in virtual-bond dihedral angles gamma
3410           if (i.gt.1)
3411      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3412      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3413      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3414           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3415      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3416      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3417 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3418           do l=1,3
3419             ggg(l)=agg(l,1)*muij(1)+
3420      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3421             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3422             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3423 cgrad            ghalf=0.5d0*ggg(l)
3424 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3425 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3426           enddo
3427 cgrad          do k=i+1,j2
3428 cgrad            do l=1,3
3429 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3430 cgrad            enddo
3431 cgrad          enddo
3432 C Remaining derivatives of eello
3433           do l=1,3
3434             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3435      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3436             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3437      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3438             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3439      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3440             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3441      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3442           enddo
3443 c          endif
3444           ENDIF
3445 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3446 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3447           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3448      &       .and. num_conti.le.maxconts) then
3449 c            write (iout,*) i,j," entered corr"
3450 C
3451 C Calculate the contact function. The ith column of the array JCONT will
3452 C contain the numbers of atoms that make contacts with the atom I (of numbers
3453 C greater than I). The arrays FACONT and GACONT will contain the values of
3454 C the contact function and its derivative.
3455 c           r0ij=1.02D0*rpp(iteli,itelj)
3456 c           r0ij=1.11D0*rpp(iteli,itelj)
3457             r0ij=2.20D0*rpp(iteli,itelj)
3458 c           r0ij=1.55D0*rpp(iteli,itelj)
3459             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3460             if (fcont.gt.0.0D0) then
3461               num_conti=num_conti+1
3462               if (num_conti.gt.maxconts) then
3463                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3464      &                         ' will skip next contacts for this conf.'
3465               else
3466                 jcont_hb(num_conti,i)=j
3467 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3468 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3469                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3470      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3471 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3472 C  terms.
3473                 d_cont(num_conti,i)=rij
3474 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3475 C     --- Electrostatic-interaction matrix ---
3476                 a_chuj(1,1,num_conti,i)=a22
3477                 a_chuj(1,2,num_conti,i)=a23
3478                 a_chuj(2,1,num_conti,i)=a32
3479                 a_chuj(2,2,num_conti,i)=a33
3480 C     --- Gradient of rij
3481                 do kkk=1,3
3482                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3483                 enddo
3484                 kkll=0
3485                 do k=1,2
3486                   do l=1,2
3487                     kkll=kkll+1
3488                     do m=1,3
3489                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3490                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3491                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3492                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3493                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3494                     enddo
3495                   enddo
3496                 enddo
3497                 ENDIF
3498                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3499 C Calculate contact energies
3500                 cosa4=4.0D0*cosa
3501                 wij=cosa-3.0D0*cosb*cosg
3502                 cosbg1=cosb+cosg
3503                 cosbg2=cosb-cosg
3504 c               fac3=dsqrt(-ael6i)/r0ij**3
3505                 fac3=dsqrt(-ael6i)*r3ij
3506 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3507                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3508                 if (ees0tmp.gt.0) then
3509                   ees0pij=dsqrt(ees0tmp)
3510                 else
3511                   ees0pij=0
3512                 endif
3513 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3514                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3515                 if (ees0tmp.gt.0) then
3516                   ees0mij=dsqrt(ees0tmp)
3517                 else
3518                   ees0mij=0
3519                 endif
3520 c               ees0mij=0.0D0
3521                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3522                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3523 C Diagnostics. Comment out or remove after debugging!
3524 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3525 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3526 c               ees0m(num_conti,i)=0.0D0
3527 C End diagnostics.
3528 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3529 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3530 C Angular derivatives of the contact function
3531                 ees0pij1=fac3/ees0pij
3532                 ees0mij1=fac3/ees0mij
3533                 fac3p=-3.0D0*fac3*rrmij
3534                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3535                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3536 c               ees0mij1=0.0D0
3537                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3538                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3539                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3540                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3541                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3542                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3543                 ecosap=ecosa1+ecosa2
3544                 ecosbp=ecosb1+ecosb2
3545                 ecosgp=ecosg1+ecosg2
3546                 ecosam=ecosa1-ecosa2
3547                 ecosbm=ecosb1-ecosb2
3548                 ecosgm=ecosg1-ecosg2
3549 C Diagnostics
3550 c               ecosap=ecosa1
3551 c               ecosbp=ecosb1
3552 c               ecosgp=ecosg1
3553 c               ecosam=0.0D0
3554 c               ecosbm=0.0D0
3555 c               ecosgm=0.0D0
3556 C End diagnostics
3557                 facont_hb(num_conti,i)=fcont
3558                 fprimcont=fprimcont/rij
3559 cd              facont_hb(num_conti,i)=1.0D0
3560 C Following line is for diagnostics.
3561 cd              fprimcont=0.0D0
3562                 do k=1,3
3563                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3564                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3565                 enddo
3566                 do k=1,3
3567                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3568                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3569                 enddo
3570                 gggp(1)=gggp(1)+ees0pijp*xj
3571                 gggp(2)=gggp(2)+ees0pijp*yj
3572                 gggp(3)=gggp(3)+ees0pijp*zj
3573                 gggm(1)=gggm(1)+ees0mijp*xj
3574                 gggm(2)=gggm(2)+ees0mijp*yj
3575                 gggm(3)=gggm(3)+ees0mijp*zj
3576 C Derivatives due to the contact function
3577                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3578                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3579                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3580                 do k=1,3
3581 c
3582 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3583 c          following the change of gradient-summation algorithm.
3584 c
3585 cgrad                  ghalfp=0.5D0*gggp(k)
3586 cgrad                  ghalfm=0.5D0*gggm(k)
3587                   gacontp_hb1(k,num_conti,i)=!ghalfp
3588      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3589      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3590                   gacontp_hb2(k,num_conti,i)=!ghalfp
3591      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3592      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3593                   gacontp_hb3(k,num_conti,i)=gggp(k)
3594                   gacontm_hb1(k,num_conti,i)=!ghalfm
3595      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3596      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3597                   gacontm_hb2(k,num_conti,i)=!ghalfm
3598      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3599      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3600                   gacontm_hb3(k,num_conti,i)=gggm(k)
3601                 enddo
3602 C Diagnostics. Comment out or remove after debugging!
3603 cdiag           do k=1,3
3604 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3605 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3606 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3607 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3608 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3609 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3610 cdiag           enddo
3611               ENDIF ! wcorr
3612               endif  ! num_conti.le.maxconts
3613             endif  ! fcont.gt.0
3614           endif    ! j.gt.i+1
3615           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3616             do k=1,4
3617               do l=1,3
3618                 ghalf=0.5d0*agg(l,k)
3619                 aggi(l,k)=aggi(l,k)+ghalf
3620                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3621                 aggj(l,k)=aggj(l,k)+ghalf
3622               enddo
3623             enddo
3624             if (j.eq.nres-1 .and. i.lt.j-2) then
3625               do k=1,4
3626                 do l=1,3
3627                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3628                 enddo
3629               enddo
3630             endif
3631           endif
3632 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3633       return
3634       end
3635 C-----------------------------------------------------------------------------
3636       subroutine eturn3(i,eello_turn3)
3637 C Third- and fourth-order contributions from turns
3638       implicit real*8 (a-h,o-z)
3639       include 'DIMENSIONS'
3640       include 'COMMON.IOUNITS'
3641       include 'COMMON.GEO'
3642       include 'COMMON.VAR'
3643       include 'COMMON.LOCAL'
3644       include 'COMMON.CHAIN'
3645       include 'COMMON.DERIV'
3646       include 'COMMON.INTERACT'
3647       include 'COMMON.CONTACTS'
3648       include 'COMMON.TORSION'
3649       include 'COMMON.VECTORS'
3650       include 'COMMON.FFIELD'
3651       include 'COMMON.CONTROL'
3652       dimension ggg(3)
3653       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3654      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3655      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3656      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3657      &  auxgmat2(2,2),auxgmatt2(2,2)
3658       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3659      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3660       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3661      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3662      &    num_conti,j1,j2
3663       j=i+2
3664 c      write (iout,*) "eturn3",i,j,j1,j2
3665       a_temp(1,1)=a22
3666       a_temp(1,2)=a23
3667       a_temp(2,1)=a32
3668       a_temp(2,2)=a33
3669 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3670 C
3671 C               Third-order contributions
3672 C
3673 C                 (i+2)o----(i+3)
3674 C                      | |
3675 C                      | |
3676 C                 (i+1)o----i
3677 C
3678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3679 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3680         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3681 c auxalary matices for theta gradient
3682 c auxalary matrix for i+1 and constant i+2
3683         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3684 c auxalary matrix for i+2 and constant i+1
3685         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3686         call transpose2(auxmat(1,1),auxmat1(1,1))
3687         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3688         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3689         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3690         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3691         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3692         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3693 C Derivatives in theta
3694         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3695      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3696         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3697      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3698
3699         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3700      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3701 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3702 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3703 cd     &    ' eello_turn3_num',4*eello_turn3_num
3704 C Derivatives in gamma(i)
3705         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3706         call transpose2(auxmat2(1,1),auxmat3(1,1))
3707         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3708         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3709 C Derivatives in gamma(i+1)
3710         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3711         call transpose2(auxmat2(1,1),auxmat3(1,1))
3712         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3713         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3714      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3715 C Cartesian derivatives
3716         do l=1,3
3717 c            ghalf1=0.5d0*agg(l,1)
3718 c            ghalf2=0.5d0*agg(l,2)
3719 c            ghalf3=0.5d0*agg(l,3)
3720 c            ghalf4=0.5d0*agg(l,4)
3721           a_temp(1,1)=aggi(l,1)!+ghalf1
3722           a_temp(1,2)=aggi(l,2)!+ghalf2
3723           a_temp(2,1)=aggi(l,3)!+ghalf3
3724           a_temp(2,2)=aggi(l,4)!+ghalf4
3725           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3726           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3727      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3728           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3729           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3730           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3731           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3732           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3733           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3734      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3735           a_temp(1,1)=aggj(l,1)!+ghalf1
3736           a_temp(1,2)=aggj(l,2)!+ghalf2
3737           a_temp(2,1)=aggj(l,3)!+ghalf3
3738           a_temp(2,2)=aggj(l,4)!+ghalf4
3739           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3740           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3741      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3742           a_temp(1,1)=aggj1(l,1)
3743           a_temp(1,2)=aggj1(l,2)
3744           a_temp(2,1)=aggj1(l,3)
3745           a_temp(2,2)=aggj1(l,4)
3746           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3747           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3748      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3749         enddo
3750       return
3751       end
3752 C-------------------------------------------------------------------------------
3753       subroutine eturn4(i,eello_turn4)
3754 C Third- and fourth-order contributions from turns
3755       implicit real*8 (a-h,o-z)
3756       include 'DIMENSIONS'
3757       include 'COMMON.IOUNITS'
3758       include 'COMMON.GEO'
3759       include 'COMMON.VAR'
3760       include 'COMMON.LOCAL'
3761       include 'COMMON.CHAIN'
3762       include 'COMMON.DERIV'
3763       include 'COMMON.INTERACT'
3764       include 'COMMON.CONTACTS'
3765       include 'COMMON.TORSION'
3766       include 'COMMON.VECTORS'
3767       include 'COMMON.FFIELD'
3768       include 'COMMON.CONTROL'
3769       dimension ggg(3)
3770       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3771      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3772      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3773      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3774      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3775      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3776      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3777       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3778      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3779       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3780      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3781      &    num_conti,j1,j2
3782       j=i+3
3783 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3784 C
3785 C               Fourth-order contributions
3786 C
3787 C                 (i+3)o----(i+4)
3788 C                     /  |
3789 C               (i+2)o   |
3790 C                     \  |
3791 C                 (i+1)o----i
3792 C
3793 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3794 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3795 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3796 c        write(iout,*)"WCHODZE W PROGRAM"
3797         a_temp(1,1)=a22
3798         a_temp(1,2)=a23
3799         a_temp(2,1)=a32
3800         a_temp(2,2)=a33
3801         iti1=itortyp(itype(i+1))
3802         iti2=itortyp(itype(i+2))
3803         iti3=itortyp(itype(i+3))
3804 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3805         call transpose2(EUg(1,1,i+1),e1t(1,1))
3806         call transpose2(Eug(1,1,i+2),e2t(1,1))
3807         call transpose2(Eug(1,1,i+3),e3t(1,1))
3808 C Ematrix derivative in theta
3809         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3810         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3811         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3812         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3813 c       eta1 in derivative theta
3814         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3815         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3816 c       auxgvec is derivative of Ub2 so i+3 theta
3817         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3818 c       auxalary matrix of E i+1
3819         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3820 c        s1=0.0
3821 c        gs1=0.0
3822         s1=scalar2(b1(1,i+2),auxvec(1))
3823 c derivative of theta i+2 with constant i+3
3824         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3825 c derivative of theta i+2 with constant i+2
3826         gs32=scalar2(b1(1,i+2),auxgvec(1))
3827 c derivative of E matix in theta of i+1
3828         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3829
3830         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3831 c       ea31 in derivative theta
3832         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3833         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3834 c auxilary matrix auxgvec of Ub2 with constant E matirx
3835         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3836 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3837         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3838
3839 c        s2=0.0
3840 c        gs2=0.0
3841         s2=scalar2(b1(1,i+1),auxvec(1))
3842 c derivative of theta i+1 with constant i+3
3843         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3844 c derivative of theta i+2 with constant i+1
3845         gs21=scalar2(b1(1,i+1),auxgvec(1))
3846 c derivative of theta i+3 with constant i+1
3847         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3848 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3849 c     &  gtb1(1,i+1)
3850         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3851 c two derivatives over diffetent matrices
3852 c gtae3e2 is derivative over i+3
3853         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3854 c ae3gte2 is derivative over i+2
3855         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3856         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3857 c three possible derivative over theta E matices
3858 c i+1
3859         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3860 c i+2
3861         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3862 c i+3
3863         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3864         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3865
3866         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3867         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3868         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3869
3870         eello_turn4=eello_turn4-(s1+s2+s3)
3871 #ifdef NEWCORR
3872         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3873      &                  -(gs13+gsE13+gsEE1)*wturn4
3874         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3875      &                    -(gs23+gs21+gsEE2)*wturn4
3876         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3877      &                    -(gs32+gsE31+gsEE3)*wturn4
3878 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3879 c     &   gs2
3880 #endif
3881         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3882      &      'eturn4',i,j,-(s1+s2+s3)
3883 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3884 c     &    ' eello_turn4_num',8*eello_turn4_num
3885 C Derivatives in gamma(i)
3886         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3887         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3888         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3889         s1=scalar2(b1(1,i+2),auxvec(1))
3890         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3891         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3892         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3893 C Derivatives in gamma(i+1)
3894         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3895         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3896         s2=scalar2(b1(1,i+1),auxvec(1))
3897         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3898         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3899         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3900         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3901 C Derivatives in gamma(i+2)
3902         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3903         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3904         s1=scalar2(b1(1,i+2),auxvec(1))
3905         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3906         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3907         s2=scalar2(b1(1,i+1),auxvec(1))
3908         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3909         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3910         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3911         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3912 C Cartesian derivatives
3913 C Derivatives of this turn contributions in DC(i+2)
3914         if (j.lt.nres-1) then
3915           do l=1,3
3916             a_temp(1,1)=agg(l,1)
3917             a_temp(1,2)=agg(l,2)
3918             a_temp(2,1)=agg(l,3)
3919             a_temp(2,2)=agg(l,4)
3920             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3921             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3922             s1=scalar2(b1(1,i+2),auxvec(1))
3923             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3924             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3925             s2=scalar2(b1(1,i+1),auxvec(1))
3926             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3927             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3928             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3929             ggg(l)=-(s1+s2+s3)
3930             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3931           enddo
3932         endif
3933 C Remaining derivatives of this turn contribution
3934         do l=1,3
3935           a_temp(1,1)=aggi(l,1)
3936           a_temp(1,2)=aggi(l,2)
3937           a_temp(2,1)=aggi(l,3)
3938           a_temp(2,2)=aggi(l,4)
3939           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3940           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3941           s1=scalar2(b1(1,i+2),auxvec(1))
3942           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3943           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3944           s2=scalar2(b1(1,i+1),auxvec(1))
3945           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3946           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3947           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3948           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3949           a_temp(1,1)=aggi1(l,1)
3950           a_temp(1,2)=aggi1(l,2)
3951           a_temp(2,1)=aggi1(l,3)
3952           a_temp(2,2)=aggi1(l,4)
3953           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3954           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3955           s1=scalar2(b1(1,i+2),auxvec(1))
3956           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3957           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3958           s2=scalar2(b1(1,i+1),auxvec(1))
3959           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3960           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3961           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3962           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3963           a_temp(1,1)=aggj(l,1)
3964           a_temp(1,2)=aggj(l,2)
3965           a_temp(2,1)=aggj(l,3)
3966           a_temp(2,2)=aggj(l,4)
3967           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3968           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3969           s1=scalar2(b1(1,i+2),auxvec(1))
3970           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3971           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3972           s2=scalar2(b1(1,i+1),auxvec(1))
3973           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3974           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3975           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3976           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3977           a_temp(1,1)=aggj1(l,1)
3978           a_temp(1,2)=aggj1(l,2)
3979           a_temp(2,1)=aggj1(l,3)
3980           a_temp(2,2)=aggj1(l,4)
3981           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3982           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3983           s1=scalar2(b1(1,i+2),auxvec(1))
3984           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3985           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3986           s2=scalar2(b1(1,i+1),auxvec(1))
3987           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3988           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3989           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3990 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3991           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3992         enddo
3993       return
3994       end
3995 C-----------------------------------------------------------------------------
3996       subroutine vecpr(u,v,w)
3997       implicit real*8(a-h,o-z)
3998       dimension u(3),v(3),w(3)
3999       w(1)=u(2)*v(3)-u(3)*v(2)
4000       w(2)=-u(1)*v(3)+u(3)*v(1)
4001       w(3)=u(1)*v(2)-u(2)*v(1)
4002       return
4003       end
4004 C-----------------------------------------------------------------------------
4005       subroutine unormderiv(u,ugrad,unorm,ungrad)
4006 C This subroutine computes the derivatives of a normalized vector u, given
4007 C the derivatives computed without normalization conditions, ugrad. Returns
4008 C ungrad.
4009       implicit none
4010       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4011       double precision vec(3)
4012       double precision scalar
4013       integer i,j
4014 c      write (2,*) 'ugrad',ugrad
4015 c      write (2,*) 'u',u
4016       do i=1,3
4017         vec(i)=scalar(ugrad(1,i),u(1))
4018       enddo
4019 c      write (2,*) 'vec',vec
4020       do i=1,3
4021         do j=1,3
4022           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4023         enddo
4024       enddo
4025 c      write (2,*) 'ungrad',ungrad
4026       return
4027       end
4028 C-----------------------------------------------------------------------------
4029       subroutine escp_soft_sphere(evdw2,evdw2_14)
4030 C
4031 C This subroutine calculates the excluded-volume interaction energy between
4032 C peptide-group centers and side chains and its gradient in virtual-bond and
4033 C side-chain vectors.
4034 C
4035       implicit real*8 (a-h,o-z)
4036       include 'DIMENSIONS'
4037       include 'COMMON.GEO'
4038       include 'COMMON.VAR'
4039       include 'COMMON.LOCAL'
4040       include 'COMMON.CHAIN'
4041       include 'COMMON.DERIV'
4042       include 'COMMON.INTERACT'
4043       include 'COMMON.FFIELD'
4044       include 'COMMON.IOUNITS'
4045       include 'COMMON.CONTROL'
4046       dimension ggg(3)
4047       evdw2=0.0D0
4048       evdw2_14=0.0d0
4049       r0_scp=4.5d0
4050 cd    print '(a)','Enter ESCP'
4051 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4052       do i=iatscp_s,iatscp_e
4053         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4054         iteli=itel(i)
4055         xi=0.5D0*(c(1,i)+c(1,i+1))
4056         yi=0.5D0*(c(2,i)+c(2,i+1))
4057         zi=0.5D0*(c(3,i)+c(3,i+1))
4058
4059         do iint=1,nscp_gr(i)
4060
4061         do j=iscpstart(i,iint),iscpend(i,iint)
4062           if (itype(j).eq.ntyp1) cycle
4063           itypj=iabs(itype(j))
4064 C Uncomment following three lines for SC-p interactions
4065 c         xj=c(1,nres+j)-xi
4066 c         yj=c(2,nres+j)-yi
4067 c         zj=c(3,nres+j)-zi
4068 C Uncomment following three lines for Ca-p interactions
4069           xj=c(1,j)-xi
4070           yj=c(2,j)-yi
4071           zj=c(3,j)-zi
4072           rij=xj*xj+yj*yj+zj*zj
4073           r0ij=r0_scp
4074           r0ijsq=r0ij*r0ij
4075           if (rij.lt.r0ijsq) then
4076             evdwij=0.25d0*(rij-r0ijsq)**2
4077             fac=rij-r0ijsq
4078           else
4079             evdwij=0.0d0
4080             fac=0.0d0
4081           endif
4082           evdw2=evdw2+evdwij
4083 C
4084 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4085 C
4086           ggg(1)=xj*fac
4087           ggg(2)=yj*fac
4088           ggg(3)=zj*fac
4089 cgrad          if (j.lt.i) then
4090 cd          write (iout,*) 'j<i'
4091 C Uncomment following three lines for SC-p interactions
4092 c           do k=1,3
4093 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4094 c           enddo
4095 cgrad          else
4096 cd          write (iout,*) 'j>i'
4097 cgrad            do k=1,3
4098 cgrad              ggg(k)=-ggg(k)
4099 C Uncomment following line for SC-p interactions
4100 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4101 cgrad            enddo
4102 cgrad          endif
4103 cgrad          do k=1,3
4104 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4105 cgrad          enddo
4106 cgrad          kstart=min0(i+1,j)
4107 cgrad          kend=max0(i-1,j-1)
4108 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4109 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4110 cgrad          do k=kstart,kend
4111 cgrad            do l=1,3
4112 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4113 cgrad            enddo
4114 cgrad          enddo
4115           do k=1,3
4116             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4117             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4118           enddo
4119         enddo
4120
4121         enddo ! iint
4122       enddo ! i
4123       return
4124       end
4125 C-----------------------------------------------------------------------------
4126       subroutine escp(evdw2,evdw2_14)
4127 C
4128 C This subroutine calculates the excluded-volume interaction energy between
4129 C peptide-group centers and side chains and its gradient in virtual-bond and
4130 C side-chain vectors.
4131 C
4132       implicit real*8 (a-h,o-z)
4133       include 'DIMENSIONS'
4134       include 'COMMON.GEO'
4135       include 'COMMON.VAR'
4136       include 'COMMON.LOCAL'
4137       include 'COMMON.CHAIN'
4138       include 'COMMON.DERIV'
4139       include 'COMMON.INTERACT'
4140       include 'COMMON.FFIELD'
4141       include 'COMMON.IOUNITS'
4142       include 'COMMON.CONTROL'
4143       dimension ggg(3)
4144       evdw2=0.0D0
4145       evdw2_14=0.0d0
4146 cd    print '(a)','Enter ESCP'
4147 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4148       do i=iatscp_s,iatscp_e
4149         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4150         iteli=itel(i)
4151         xi=0.5D0*(c(1,i)+c(1,i+1))
4152         yi=0.5D0*(c(2,i)+c(2,i+1))
4153         zi=0.5D0*(c(3,i)+c(3,i+1))
4154
4155         do iint=1,nscp_gr(i)
4156
4157         do j=iscpstart(i,iint),iscpend(i,iint)
4158           itypj=iabs(itype(j))
4159           if (itypj.eq.ntyp1) cycle
4160 C Uncomment following three lines for SC-p interactions
4161 c         xj=c(1,nres+j)-xi
4162 c         yj=c(2,nres+j)-yi
4163 c         zj=c(3,nres+j)-zi
4164 C Uncomment following three lines for Ca-p interactions
4165           xj=c(1,j)-xi
4166           yj=c(2,j)-yi
4167           zj=c(3,j)-zi
4168           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4169           fac=rrij**expon2
4170           e1=fac*fac*aad(itypj,iteli)
4171           e2=fac*bad(itypj,iteli)
4172           if (iabs(j-i) .le. 2) then
4173             e1=scal14*e1
4174             e2=scal14*e2
4175             evdw2_14=evdw2_14+e1+e2
4176           endif
4177           evdwij=e1+e2
4178           evdw2=evdw2+evdwij
4179           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4180      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4181      &       bad(itypj,iteli)
4182 C
4183 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4184 C
4185           fac=-(evdwij+e1)*rrij
4186           ggg(1)=xj*fac
4187           ggg(2)=yj*fac
4188           ggg(3)=zj*fac
4189 cgrad          if (j.lt.i) then
4190 cd          write (iout,*) 'j<i'
4191 C Uncomment following three lines for SC-p interactions
4192 c           do k=1,3
4193 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4194 c           enddo
4195 cgrad          else
4196 cd          write (iout,*) 'j>i'
4197 cgrad            do k=1,3
4198 cgrad              ggg(k)=-ggg(k)
4199 C Uncomment following line for SC-p interactions
4200 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4201 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4202 cgrad            enddo
4203 cgrad          endif
4204 cgrad          do k=1,3
4205 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4206 cgrad          enddo
4207 cgrad          kstart=min0(i+1,j)
4208 cgrad          kend=max0(i-1,j-1)
4209 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4210 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4211 cgrad          do k=kstart,kend
4212 cgrad            do l=1,3
4213 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4214 cgrad            enddo
4215 cgrad          enddo
4216           do k=1,3
4217             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4218             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4219           enddo
4220         enddo
4221
4222         enddo ! iint
4223       enddo ! i
4224       do i=1,nct
4225         do j=1,3
4226           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4227           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4228           gradx_scp(j,i)=expon*gradx_scp(j,i)
4229         enddo
4230       enddo
4231 C******************************************************************************
4232 C
4233 C                              N O T E !!!
4234 C
4235 C To save time the factor EXPON has been extracted from ALL components
4236 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4237 C use!
4238 C
4239 C******************************************************************************
4240       return
4241       end
4242 C--------------------------------------------------------------------------
4243       subroutine edis(ehpb)
4244 C
4245 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4246 C
4247       implicit real*8 (a-h,o-z)
4248       include 'DIMENSIONS'
4249       include 'COMMON.SBRIDGE'
4250       include 'COMMON.CHAIN'
4251       include 'COMMON.DERIV'
4252       include 'COMMON.VAR'
4253       include 'COMMON.INTERACT'
4254       include 'COMMON.IOUNITS'
4255       dimension ggg(3)
4256       ehpb=0.0D0
4257 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4258 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4259       if (link_end.eq.0) return
4260       do i=link_start,link_end
4261 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4262 C CA-CA distance used in regularization of structure.
4263         ii=ihpb(i)
4264         jj=jhpb(i)
4265 C iii and jjj point to the residues for which the distance is assigned.
4266         if (ii.gt.nres) then
4267           iii=ii-nres
4268           jjj=jj-nres
4269         else
4270           iii=ii
4271           jjj=jj
4272         endif
4273 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4274 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4275 C    distance and angle dependent SS bond potential.
4276         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4277      & iabs(itype(jjj)).eq.1) then
4278           call ssbond_ene(iii,jjj,eij)
4279           ehpb=ehpb+2*eij
4280 cd          write (iout,*) "eij",eij
4281         else
4282 C Calculate the distance between the two points and its difference from the
4283 C target distance.
4284         dd=dist(ii,jj)
4285         rdis=dd-dhpb(i)
4286 C Get the force constant corresponding to this distance.
4287         waga=forcon(i)
4288 C Calculate the contribution to energy.
4289         ehpb=ehpb+waga*rdis*rdis
4290 C
4291 C Evaluate gradient.
4292 C
4293         fac=waga*rdis/dd
4294 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4295 cd   &   ' waga=',waga,' fac=',fac
4296         do j=1,3
4297           ggg(j)=fac*(c(j,jj)-c(j,ii))
4298         enddo
4299 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4300 C If this is a SC-SC distance, we need to calculate the contributions to the
4301 C Cartesian gradient in the SC vectors (ghpbx).
4302         if (iii.lt.ii) then
4303           do j=1,3
4304             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4305             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4306           enddo
4307         endif
4308 cgrad        do j=iii,jjj-1
4309 cgrad          do k=1,3
4310 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4311 cgrad          enddo
4312 cgrad        enddo
4313         do k=1,3
4314           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4315           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4316         enddo
4317         endif
4318       enddo
4319       ehpb=0.5D0*ehpb
4320       return
4321       end
4322 C--------------------------------------------------------------------------
4323       subroutine ssbond_ene(i,j,eij)
4324 C
4325 C Calculate the distance and angle dependent SS-bond potential energy
4326 C using a free-energy function derived based on RHF/6-31G** ab initio
4327 C calculations of diethyl disulfide.
4328 C
4329 C A. Liwo and U. Kozlowska, 11/24/03
4330 C
4331       implicit real*8 (a-h,o-z)
4332       include 'DIMENSIONS'
4333       include 'COMMON.SBRIDGE'
4334       include 'COMMON.CHAIN'
4335       include 'COMMON.DERIV'
4336       include 'COMMON.LOCAL'
4337       include 'COMMON.INTERACT'
4338       include 'COMMON.VAR'
4339       include 'COMMON.IOUNITS'
4340       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4341       itypi=iabs(itype(i))
4342       xi=c(1,nres+i)
4343       yi=c(2,nres+i)
4344       zi=c(3,nres+i)
4345       dxi=dc_norm(1,nres+i)
4346       dyi=dc_norm(2,nres+i)
4347       dzi=dc_norm(3,nres+i)
4348 c      dsci_inv=dsc_inv(itypi)
4349       dsci_inv=vbld_inv(nres+i)
4350       itypj=iabs(itype(j))
4351 c      dscj_inv=dsc_inv(itypj)
4352       dscj_inv=vbld_inv(nres+j)
4353       xj=c(1,nres+j)-xi
4354       yj=c(2,nres+j)-yi
4355       zj=c(3,nres+j)-zi
4356       dxj=dc_norm(1,nres+j)
4357       dyj=dc_norm(2,nres+j)
4358       dzj=dc_norm(3,nres+j)
4359       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4360       rij=dsqrt(rrij)
4361       erij(1)=xj*rij
4362       erij(2)=yj*rij
4363       erij(3)=zj*rij
4364       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4365       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4366       om12=dxi*dxj+dyi*dyj+dzi*dzj
4367       do k=1,3
4368         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4369         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4370       enddo
4371       rij=1.0d0/rij
4372       deltad=rij-d0cm
4373       deltat1=1.0d0-om1
4374       deltat2=1.0d0+om2
4375       deltat12=om2-om1+2.0d0
4376       cosphi=om12-om1*om2
4377       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4378      &  +akct*deltad*deltat12
4379      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4380 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4381 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4382 c     &  " deltat12",deltat12," eij",eij
4383       ed=2*akcm*deltad+akct*deltat12
4384       pom1=akct*deltad
4385       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4386       eom1=-2*akth*deltat1-pom1-om2*pom2
4387       eom2= 2*akth*deltat2+pom1-om1*pom2
4388       eom12=pom2
4389       do k=1,3
4390         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4391         ghpbx(k,i)=ghpbx(k,i)-ggk
4392      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4393      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4394         ghpbx(k,j)=ghpbx(k,j)+ggk
4395      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4396      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4397         ghpbc(k,i)=ghpbc(k,i)-ggk
4398         ghpbc(k,j)=ghpbc(k,j)+ggk
4399       enddo
4400 C
4401 C Calculate the components of the gradient in DC and X
4402 C
4403 cgrad      do k=i,j-1
4404 cgrad        do l=1,3
4405 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4406 cgrad        enddo
4407 cgrad      enddo
4408       return
4409       end
4410 C--------------------------------------------------------------------------
4411       subroutine ebond(estr)
4412 c
4413 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4414 c
4415       implicit real*8 (a-h,o-z)
4416       include 'DIMENSIONS'
4417       include 'COMMON.LOCAL'
4418       include 'COMMON.GEO'
4419       include 'COMMON.INTERACT'
4420       include 'COMMON.DERIV'
4421       include 'COMMON.VAR'
4422       include 'COMMON.CHAIN'
4423       include 'COMMON.IOUNITS'
4424       include 'COMMON.NAMES'
4425       include 'COMMON.FFIELD'
4426       include 'COMMON.CONTROL'
4427       include 'COMMON.SETUP'
4428       double precision u(3),ud(3)
4429       estr=0.0d0
4430       estr1=0.0d0
4431       do i=ibondp_start,ibondp_end
4432         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4433           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4434           do j=1,3
4435           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4436      &      *dc(j,i-1)/vbld(i)
4437           enddo
4438           if (energy_dec) write(iout,*)
4439      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4440         else
4441         diff = vbld(i)-vbldp0
4442         if (energy_dec) write (iout,*)
4443      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4444         estr=estr+diff*diff
4445         do j=1,3
4446           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4447         enddo
4448 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4449         endif
4450       enddo
4451       estr=0.5d0*AKP*estr+estr1
4452 c
4453 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4454 c
4455       do i=ibond_start,ibond_end
4456         iti=iabs(itype(i))
4457         if (iti.ne.10 .and. iti.ne.ntyp1) then
4458           nbi=nbondterm(iti)
4459           if (nbi.eq.1) then
4460             diff=vbld(i+nres)-vbldsc0(1,iti)
4461             if (energy_dec) write (iout,*)
4462      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4463      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4464             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4465             do j=1,3
4466               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4467             enddo
4468           else
4469             do j=1,nbi
4470               diff=vbld(i+nres)-vbldsc0(j,iti)
4471               ud(j)=aksc(j,iti)*diff
4472               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4473             enddo
4474             uprod=u(1)
4475             do j=2,nbi
4476               uprod=uprod*u(j)
4477             enddo
4478             usum=0.0d0
4479             usumsqder=0.0d0
4480             do j=1,nbi
4481               uprod1=1.0d0
4482               uprod2=1.0d0
4483               do k=1,nbi
4484                 if (k.ne.j) then
4485                   uprod1=uprod1*u(k)
4486                   uprod2=uprod2*u(k)*u(k)
4487                 endif
4488               enddo
4489               usum=usum+uprod1
4490               usumsqder=usumsqder+ud(j)*uprod2
4491             enddo
4492             estr=estr+uprod/usum
4493             do j=1,3
4494              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4495             enddo
4496           endif
4497         endif
4498       enddo
4499       return
4500       end
4501 #ifdef CRYST_THETA
4502 C--------------------------------------------------------------------------
4503       subroutine ebend(etheta)
4504 C
4505 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4506 C angles gamma and its derivatives in consecutive thetas and gammas.
4507 C
4508       implicit real*8 (a-h,o-z)
4509       include 'DIMENSIONS'
4510       include 'COMMON.LOCAL'
4511       include 'COMMON.GEO'
4512       include 'COMMON.INTERACT'
4513       include 'COMMON.DERIV'
4514       include 'COMMON.VAR'
4515       include 'COMMON.CHAIN'
4516       include 'COMMON.IOUNITS'
4517       include 'COMMON.NAMES'
4518       include 'COMMON.FFIELD'
4519       include 'COMMON.CONTROL'
4520       common /calcthet/ term1,term2,termm,diffak,ratak,
4521      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4522      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4523       double precision y(2),z(2)
4524       delta=0.02d0*pi
4525 c      time11=dexp(-2*time)
4526 c      time12=1.0d0
4527       etheta=0.0D0
4528 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4529       do i=ithet_start,ithet_end
4530         if (itype(i-1).eq.ntyp1) cycle
4531 C Zero the energy function and its derivative at 0 or pi.
4532         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4533         it=itype(i-1)
4534         ichir1=isign(1,itype(i-2))
4535         ichir2=isign(1,itype(i))
4536          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4537          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4538          if (itype(i-1).eq.10) then
4539           itype1=isign(10,itype(i-2))
4540           ichir11=isign(1,itype(i-2))
4541           ichir12=isign(1,itype(i-2))
4542           itype2=isign(10,itype(i))
4543           ichir21=isign(1,itype(i))
4544           ichir22=isign(1,itype(i))
4545          endif
4546
4547         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4548 #ifdef OSF
4549           phii=phi(i)
4550           if (phii.ne.phii) phii=150.0
4551 #else
4552           phii=phi(i)
4553 #endif
4554           y(1)=dcos(phii)
4555           y(2)=dsin(phii)
4556         else
4557           y(1)=0.0D0
4558           y(2)=0.0D0
4559         endif
4560         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4561 #ifdef OSF
4562           phii1=phi(i+1)
4563           if (phii1.ne.phii1) phii1=150.0
4564           phii1=pinorm(phii1)
4565           z(1)=cos(phii1)
4566 #else
4567           phii1=phi(i+1)
4568           z(1)=dcos(phii1)
4569 #endif
4570           z(2)=dsin(phii1)
4571         else
4572           z(1)=0.0D0
4573           z(2)=0.0D0
4574         endif
4575 C Calculate the "mean" value of theta from the part of the distribution
4576 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4577 C In following comments this theta will be referred to as t_c.
4578         thet_pred_mean=0.0d0
4579         do k=1,2
4580             athetk=athet(k,it,ichir1,ichir2)
4581             bthetk=bthet(k,it,ichir1,ichir2)
4582           if (it.eq.10) then
4583              athetk=athet(k,itype1,ichir11,ichir12)
4584              bthetk=bthet(k,itype2,ichir21,ichir22)
4585           endif
4586          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4587         enddo
4588         dthett=thet_pred_mean*ssd
4589         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4590 C Derivatives of the "mean" values in gamma1 and gamma2.
4591         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4592      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4593          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4594      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4595          if (it.eq.10) then
4596       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4597      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4598         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4599      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4600          endif
4601         if (theta(i).gt.pi-delta) then
4602           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4603      &         E_tc0)
4604           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4605           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4606           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4607      &        E_theta)
4608           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4609      &        E_tc)
4610         else if (theta(i).lt.delta) then
4611           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4612           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4613           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4614      &        E_theta)
4615           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4616           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4617      &        E_tc)
4618         else
4619           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4620      &        E_theta,E_tc)
4621         endif
4622         etheta=etheta+ethetai
4623         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4624      &      'ebend',i,ethetai
4625         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4626         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4627         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4628       enddo
4629 C Ufff.... We've done all this!!!
4630       return
4631       end
4632 C---------------------------------------------------------------------------
4633       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4634      &     E_tc)
4635       implicit real*8 (a-h,o-z)
4636       include 'DIMENSIONS'
4637       include 'COMMON.LOCAL'
4638       include 'COMMON.IOUNITS'
4639       common /calcthet/ term1,term2,termm,diffak,ratak,
4640      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4641      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4642 C Calculate the contributions to both Gaussian lobes.
4643 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4644 C The "polynomial part" of the "standard deviation" of this part of
4645 C the distribution.
4646         sig=polthet(3,it)
4647         do j=2,0,-1
4648           sig=sig*thet_pred_mean+polthet(j,it)
4649         enddo
4650 C Derivative of the "interior part" of the "standard deviation of the"
4651 C gamma-dependent Gaussian lobe in t_c.
4652         sigtc=3*polthet(3,it)
4653         do j=2,1,-1
4654           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4655         enddo
4656         sigtc=sig*sigtc
4657 C Set the parameters of both Gaussian lobes of the distribution.
4658 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4659         fac=sig*sig+sigc0(it)
4660         sigcsq=fac+fac
4661         sigc=1.0D0/sigcsq
4662 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4663         sigsqtc=-4.0D0*sigcsq*sigtc
4664 c       print *,i,sig,sigtc,sigsqtc
4665 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4666         sigtc=-sigtc/(fac*fac)
4667 C Following variable is sigma(t_c)**(-2)
4668         sigcsq=sigcsq*sigcsq
4669         sig0i=sig0(it)
4670         sig0inv=1.0D0/sig0i**2
4671         delthec=thetai-thet_pred_mean
4672         delthe0=thetai-theta0i
4673         term1=-0.5D0*sigcsq*delthec*delthec
4674         term2=-0.5D0*sig0inv*delthe0*delthe0
4675 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4676 C NaNs in taking the logarithm. We extract the largest exponent which is added
4677 C to the energy (this being the log of the distribution) at the end of energy
4678 C term evaluation for this virtual-bond angle.
4679         if (term1.gt.term2) then
4680           termm=term1
4681           term2=dexp(term2-termm)
4682           term1=1.0d0
4683         else
4684           termm=term2
4685           term1=dexp(term1-termm)
4686           term2=1.0d0
4687         endif
4688 C The ratio between the gamma-independent and gamma-dependent lobes of
4689 C the distribution is a Gaussian function of thet_pred_mean too.
4690         diffak=gthet(2,it)-thet_pred_mean
4691         ratak=diffak/gthet(3,it)**2
4692         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4693 C Let's differentiate it in thet_pred_mean NOW.
4694         aktc=ak*ratak
4695 C Now put together the distribution terms to make complete distribution.
4696         termexp=term1+ak*term2
4697         termpre=sigc+ak*sig0i
4698 C Contribution of the bending energy from this theta is just the -log of
4699 C the sum of the contributions from the two lobes and the pre-exponential
4700 C factor. Simple enough, isn't it?
4701         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4702 C NOW the derivatives!!!
4703 C 6/6/97 Take into account the deformation.
4704         E_theta=(delthec*sigcsq*term1
4705      &       +ak*delthe0*sig0inv*term2)/termexp
4706         E_tc=((sigtc+aktc*sig0i)/termpre
4707      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4708      &       aktc*term2)/termexp)
4709       return
4710       end
4711 c-----------------------------------------------------------------------------
4712       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4713       implicit real*8 (a-h,o-z)
4714       include 'DIMENSIONS'
4715       include 'COMMON.LOCAL'
4716       include 'COMMON.IOUNITS'
4717       common /calcthet/ term1,term2,termm,diffak,ratak,
4718      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4719      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4720       delthec=thetai-thet_pred_mean
4721       delthe0=thetai-theta0i
4722 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4723       t3 = thetai-thet_pred_mean
4724       t6 = t3**2
4725       t9 = term1
4726       t12 = t3*sigcsq
4727       t14 = t12+t6*sigsqtc
4728       t16 = 1.0d0
4729       t21 = thetai-theta0i
4730       t23 = t21**2
4731       t26 = term2
4732       t27 = t21*t26
4733       t32 = termexp
4734       t40 = t32**2
4735       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4736      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4737      & *(-t12*t9-ak*sig0inv*t27)
4738       return
4739       end
4740 #else
4741 C--------------------------------------------------------------------------
4742       subroutine ebend(etheta)
4743 C
4744 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4745 C angles gamma and its derivatives in consecutive thetas and gammas.
4746 C ab initio-derived potentials from
4747 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4748 C
4749       implicit real*8 (a-h,o-z)
4750       include 'DIMENSIONS'
4751       include 'COMMON.LOCAL'
4752       include 'COMMON.GEO'
4753       include 'COMMON.INTERACT'
4754       include 'COMMON.DERIV'
4755       include 'COMMON.VAR'
4756       include 'COMMON.CHAIN'
4757       include 'COMMON.IOUNITS'
4758       include 'COMMON.NAMES'
4759       include 'COMMON.FFIELD'
4760       include 'COMMON.CONTROL'
4761       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4762      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4763      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4764      & sinph1ph2(maxdouble,maxdouble)
4765       logical lprn /.false./, lprn1 /.false./
4766       etheta=0.0D0
4767       do i=ithet_start,ithet_end
4768         if (itype(i-1).eq.ntyp1) cycle
4769         if (iabs(itype(i+1)).eq.20) iblock=2
4770         if (iabs(itype(i+1)).ne.20) iblock=1
4771         dethetai=0.0d0
4772         dephii=0.0d0
4773         dephii1=0.0d0
4774         theti2=0.5d0*theta(i)
4775         ityp2=ithetyp((itype(i-1)))
4776         do k=1,nntheterm
4777           coskt(k)=dcos(k*theti2)
4778           sinkt(k)=dsin(k*theti2)
4779         enddo
4780         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4781 #ifdef OSF
4782           phii=phi(i)
4783           if (phii.ne.phii) phii=150.0
4784 #else
4785           phii=phi(i)
4786 #endif
4787           ityp1=ithetyp((itype(i-2)))
4788 C propagation of chirality for glycine type
4789           do k=1,nsingle
4790             cosph1(k)=dcos(k*phii)
4791             sinph1(k)=dsin(k*phii)
4792           enddo
4793         else
4794           phii=0.0d0
4795           ityp1=nthetyp+1
4796           do k=1,nsingle
4797             cosph1(k)=0.0d0
4798             sinph1(k)=0.0d0
4799           enddo
4800         endif
4801         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4802 #ifdef OSF
4803           phii1=phi(i+1)
4804           if (phii1.ne.phii1) phii1=150.0
4805           phii1=pinorm(phii1)
4806 #else
4807           phii1=phi(i+1)
4808 #endif
4809           ityp3=ithetyp((itype(i)))
4810           do k=1,nsingle
4811             cosph2(k)=dcos(k*phii1)
4812             sinph2(k)=dsin(k*phii1)
4813           enddo
4814         else
4815           phii1=0.0d0
4816           ityp3=nthetyp+1
4817           do k=1,nsingle
4818             cosph2(k)=0.0d0
4819             sinph2(k)=0.0d0
4820           enddo
4821         endif
4822         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4823         do k=1,ndouble
4824           do l=1,k-1
4825             ccl=cosph1(l)*cosph2(k-l)
4826             ssl=sinph1(l)*sinph2(k-l)
4827             scl=sinph1(l)*cosph2(k-l)
4828             csl=cosph1(l)*sinph2(k-l)
4829             cosph1ph2(l,k)=ccl-ssl
4830             cosph1ph2(k,l)=ccl+ssl
4831             sinph1ph2(l,k)=scl+csl
4832             sinph1ph2(k,l)=scl-csl
4833           enddo
4834         enddo
4835         if (lprn) then
4836         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4837      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4838         write (iout,*) "coskt and sinkt"
4839         do k=1,nntheterm
4840           write (iout,*) k,coskt(k),sinkt(k)
4841         enddo
4842         endif
4843         do k=1,ntheterm
4844           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4845           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4846      &      *coskt(k)
4847           if (lprn)
4848      &    write (iout,*) "k",k,"
4849      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4850      &     " ethetai",ethetai
4851         enddo
4852         if (lprn) then
4853         write (iout,*) "cosph and sinph"
4854         do k=1,nsingle
4855           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4856         enddo
4857         write (iout,*) "cosph1ph2 and sinph2ph2"
4858         do k=2,ndouble
4859           do l=1,k-1
4860             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4861      &         sinph1ph2(l,k),sinph1ph2(k,l)
4862           enddo
4863         enddo
4864         write(iout,*) "ethetai",ethetai
4865         endif
4866         do m=1,ntheterm2
4867           do k=1,nsingle
4868             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4869      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4870      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4871      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4872             ethetai=ethetai+sinkt(m)*aux
4873             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4874             dephii=dephii+k*sinkt(m)*(
4875      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4876      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4877             dephii1=dephii1+k*sinkt(m)*(
4878      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4879      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4880             if (lprn)
4881      &      write (iout,*) "m",m," k",k," bbthet",
4882      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4883      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4884      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4885      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4886           enddo
4887         enddo
4888         if (lprn)
4889      &  write(iout,*) "ethetai",ethetai
4890         do m=1,ntheterm3
4891           do k=2,ndouble
4892             do l=1,k-1
4893               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4894      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4895      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4896      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4897               ethetai=ethetai+sinkt(m)*aux
4898               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4899               dephii=dephii+l*sinkt(m)*(
4900      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4901      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4902      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4903      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4904               dephii1=dephii1+(k-l)*sinkt(m)*(
4905      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4906      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4907      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4908      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4909               if (lprn) then
4910               write (iout,*) "m",m," k",k," l",l," ffthet",
4911      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4912      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4913      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4914      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4915      &            " ethetai",ethetai
4916               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4917      &            cosph1ph2(k,l)*sinkt(m),
4918      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4919               endif
4920             enddo
4921           enddo
4922         enddo
4923 10      continue
4924 c        lprn1=.true.
4925         if (lprn1)
4926      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4927      &   i,theta(i)*rad2deg,phii*rad2deg,
4928      &   phii1*rad2deg,ethetai
4929 c        lprn1=.false.
4930         etheta=etheta+ethetai
4931         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4932         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4933         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4934       enddo
4935       return
4936       end
4937 #endif
4938 #ifdef CRYST_SC
4939 c-----------------------------------------------------------------------------
4940       subroutine esc(escloc)
4941 C Calculate the local energy of a side chain and its derivatives in the
4942 C corresponding virtual-bond valence angles THETA and the spherical angles
4943 C ALPHA and OMEGA.
4944       implicit real*8 (a-h,o-z)
4945       include 'DIMENSIONS'
4946       include 'COMMON.GEO'
4947       include 'COMMON.LOCAL'
4948       include 'COMMON.VAR'
4949       include 'COMMON.INTERACT'
4950       include 'COMMON.DERIV'
4951       include 'COMMON.CHAIN'
4952       include 'COMMON.IOUNITS'
4953       include 'COMMON.NAMES'
4954       include 'COMMON.FFIELD'
4955       include 'COMMON.CONTROL'
4956       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4957      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4958       common /sccalc/ time11,time12,time112,theti,it,nlobit
4959       delta=0.02d0*pi
4960       escloc=0.0D0
4961 c     write (iout,'(a)') 'ESC'
4962       do i=loc_start,loc_end
4963         it=itype(i)
4964         if (it.eq.ntyp1) cycle
4965         if (it.eq.10) goto 1
4966         nlobit=nlob(iabs(it))
4967 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4968 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4969         theti=theta(i+1)-pipol
4970         x(1)=dtan(theti)
4971         x(2)=alph(i)
4972         x(3)=omeg(i)
4973
4974         if (x(2).gt.pi-delta) then
4975           xtemp(1)=x(1)
4976           xtemp(2)=pi-delta
4977           xtemp(3)=x(3)
4978           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4979           xtemp(2)=pi
4980           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4981           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4982      &        escloci,dersc(2))
4983           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4984      &        ddersc0(1),dersc(1))
4985           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4986      &        ddersc0(3),dersc(3))
4987           xtemp(2)=pi-delta
4988           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4989           xtemp(2)=pi
4990           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4991           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4992      &            dersc0(2),esclocbi,dersc02)
4993           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4994      &            dersc12,dersc01)
4995           call splinthet(x(2),0.5d0*delta,ss,ssd)
4996           dersc0(1)=dersc01
4997           dersc0(2)=dersc02
4998           dersc0(3)=0.0d0
4999           do k=1,3
5000             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5001           enddo
5002           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5003 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5004 c    &             esclocbi,ss,ssd
5005           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5006 c         escloci=esclocbi
5007 c         write (iout,*) escloci
5008         else if (x(2).lt.delta) then
5009           xtemp(1)=x(1)
5010           xtemp(2)=delta
5011           xtemp(3)=x(3)
5012           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5013           xtemp(2)=0.0d0
5014           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5015           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5016      &        escloci,dersc(2))
5017           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5018      &        ddersc0(1),dersc(1))
5019           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5020      &        ddersc0(3),dersc(3))
5021           xtemp(2)=delta
5022           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5023           xtemp(2)=0.0d0
5024           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5025           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5026      &            dersc0(2),esclocbi,dersc02)
5027           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5028      &            dersc12,dersc01)
5029           dersc0(1)=dersc01
5030           dersc0(2)=dersc02
5031           dersc0(3)=0.0d0
5032           call splinthet(x(2),0.5d0*delta,ss,ssd)
5033           do k=1,3
5034             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5035           enddo
5036           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5037 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5038 c    &             esclocbi,ss,ssd
5039           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5040 c         write (iout,*) escloci
5041         else
5042           call enesc(x,escloci,dersc,ddummy,.false.)
5043         endif
5044
5045         escloc=escloc+escloci
5046         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5047      &     'escloc',i,escloci
5048 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5049
5050         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5051      &   wscloc*dersc(1)
5052         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5053         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5054     1   continue
5055       enddo
5056       return
5057       end
5058 C---------------------------------------------------------------------------
5059       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5060       implicit real*8 (a-h,o-z)
5061       include 'DIMENSIONS'
5062       include 'COMMON.GEO'
5063       include 'COMMON.LOCAL'
5064       include 'COMMON.IOUNITS'
5065       common /sccalc/ time11,time12,time112,theti,it,nlobit
5066       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5067       double precision contr(maxlob,-1:1)
5068       logical mixed
5069 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5070         escloc_i=0.0D0
5071         do j=1,3
5072           dersc(j)=0.0D0
5073           if (mixed) ddersc(j)=0.0d0
5074         enddo
5075         x3=x(3)
5076
5077 C Because of periodicity of the dependence of the SC energy in omega we have
5078 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5079 C To avoid underflows, first compute & store the exponents.
5080
5081         do iii=-1,1
5082
5083           x(3)=x3+iii*dwapi
5084
5085           do j=1,nlobit
5086             do k=1,3
5087               z(k)=x(k)-censc(k,j,it)
5088             enddo
5089             do k=1,3
5090               Axk=0.0D0
5091               do l=1,3
5092                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5093               enddo
5094               Ax(k,j,iii)=Axk
5095             enddo
5096             expfac=0.0D0
5097             do k=1,3
5098               expfac=expfac+Ax(k,j,iii)*z(k)
5099             enddo
5100             contr(j,iii)=expfac
5101           enddo ! j
5102
5103         enddo ! iii
5104
5105         x(3)=x3
5106 C As in the case of ebend, we want to avoid underflows in exponentiation and
5107 C subsequent NaNs and INFs in energy calculation.
5108 C Find the largest exponent
5109         emin=contr(1,-1)
5110         do iii=-1,1
5111           do j=1,nlobit
5112             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5113           enddo
5114         enddo
5115         emin=0.5D0*emin
5116 cd      print *,'it=',it,' emin=',emin
5117
5118 C Compute the contribution to SC energy and derivatives
5119         do iii=-1,1
5120
5121           do j=1,nlobit
5122 #ifdef OSF
5123             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5124             if(adexp.ne.adexp) adexp=1.0
5125             expfac=dexp(adexp)
5126 #else
5127             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5128 #endif
5129 cd          print *,'j=',j,' expfac=',expfac
5130             escloc_i=escloc_i+expfac
5131             do k=1,3
5132               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5133             enddo
5134             if (mixed) then
5135               do k=1,3,2
5136                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5137      &            +gaussc(k,2,j,it))*expfac
5138               enddo
5139             endif
5140           enddo
5141
5142         enddo ! iii
5143
5144         dersc(1)=dersc(1)/cos(theti)**2
5145         ddersc(1)=ddersc(1)/cos(theti)**2
5146         ddersc(3)=ddersc(3)
5147
5148         escloci=-(dlog(escloc_i)-emin)
5149         do j=1,3
5150           dersc(j)=dersc(j)/escloc_i
5151         enddo
5152         if (mixed) then
5153           do j=1,3,2
5154             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5155           enddo
5156         endif
5157       return
5158       end
5159 C------------------------------------------------------------------------------
5160       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5161       implicit real*8 (a-h,o-z)
5162       include 'DIMENSIONS'
5163       include 'COMMON.GEO'
5164       include 'COMMON.LOCAL'
5165       include 'COMMON.IOUNITS'
5166       common /sccalc/ time11,time12,time112,theti,it,nlobit
5167       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5168       double precision contr(maxlob)
5169       logical mixed
5170
5171       escloc_i=0.0D0
5172
5173       do j=1,3
5174         dersc(j)=0.0D0
5175       enddo
5176
5177       do j=1,nlobit
5178         do k=1,2
5179           z(k)=x(k)-censc(k,j,it)
5180         enddo
5181         z(3)=dwapi
5182         do k=1,3
5183           Axk=0.0D0
5184           do l=1,3
5185             Axk=Axk+gaussc(l,k,j,it)*z(l)
5186           enddo
5187           Ax(k,j)=Axk
5188         enddo
5189         expfac=0.0D0
5190         do k=1,3
5191           expfac=expfac+Ax(k,j)*z(k)
5192         enddo
5193         contr(j)=expfac
5194       enddo ! j
5195
5196 C As in the case of ebend, we want to avoid underflows in exponentiation and
5197 C subsequent NaNs and INFs in energy calculation.
5198 C Find the largest exponent
5199       emin=contr(1)
5200       do j=1,nlobit
5201         if (emin.gt.contr(j)) emin=contr(j)
5202       enddo
5203       emin=0.5D0*emin
5204
5205 C Compute the contribution to SC energy and derivatives
5206
5207       dersc12=0.0d0
5208       do j=1,nlobit
5209         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5210         escloc_i=escloc_i+expfac
5211         do k=1,2
5212           dersc(k)=dersc(k)+Ax(k,j)*expfac
5213         enddo
5214         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5215      &            +gaussc(1,2,j,it))*expfac
5216         dersc(3)=0.0d0
5217       enddo
5218
5219       dersc(1)=dersc(1)/cos(theti)**2
5220       dersc12=dersc12/cos(theti)**2
5221       escloci=-(dlog(escloc_i)-emin)
5222       do j=1,2
5223         dersc(j)=dersc(j)/escloc_i
5224       enddo
5225       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5226       return
5227       end
5228 #else
5229 c----------------------------------------------------------------------------------
5230       subroutine esc(escloc)
5231 C Calculate the local energy of a side chain and its derivatives in the
5232 C corresponding virtual-bond valence angles THETA and the spherical angles
5233 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5234 C added by Urszula Kozlowska. 07/11/2007
5235 C
5236       implicit real*8 (a-h,o-z)
5237       include 'DIMENSIONS'
5238       include 'COMMON.GEO'
5239       include 'COMMON.LOCAL'
5240       include 'COMMON.VAR'
5241       include 'COMMON.SCROT'
5242       include 'COMMON.INTERACT'
5243       include 'COMMON.DERIV'
5244       include 'COMMON.CHAIN'
5245       include 'COMMON.IOUNITS'
5246       include 'COMMON.NAMES'
5247       include 'COMMON.FFIELD'
5248       include 'COMMON.CONTROL'
5249       include 'COMMON.VECTORS'
5250       double precision x_prime(3),y_prime(3),z_prime(3)
5251      &    , sumene,dsc_i,dp2_i,x(65),
5252      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5253      &    de_dxx,de_dyy,de_dzz,de_dt
5254       double precision s1_t,s1_6_t,s2_t,s2_6_t
5255       double precision
5256      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5257      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5258      & dt_dCi(3),dt_dCi1(3)
5259       common /sccalc/ time11,time12,time112,theti,it,nlobit
5260       delta=0.02d0*pi
5261       escloc=0.0D0
5262       do i=loc_start,loc_end
5263         if (itype(i).eq.ntyp1) cycle
5264         costtab(i+1) =dcos(theta(i+1))
5265         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5266         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5267         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5268         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5269         cosfac=dsqrt(cosfac2)
5270         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5271         sinfac=dsqrt(sinfac2)
5272         it=iabs(itype(i))
5273         if (it.eq.10) goto 1
5274 c
5275 C  Compute the axes of tghe local cartesian coordinates system; store in
5276 c   x_prime, y_prime and z_prime
5277 c
5278         do j=1,3
5279           x_prime(j) = 0.00
5280           y_prime(j) = 0.00
5281           z_prime(j) = 0.00
5282         enddo
5283 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5284 C     &   dc_norm(3,i+nres)
5285         do j = 1,3
5286           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5287           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5288         enddo
5289         do j = 1,3
5290           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5291         enddo
5292 c       write (2,*) "i",i
5293 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5294 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5295 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5296 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5297 c      & " xy",scalar(x_prime(1),y_prime(1)),
5298 c      & " xz",scalar(x_prime(1),z_prime(1)),
5299 c      & " yy",scalar(y_prime(1),y_prime(1)),
5300 c      & " yz",scalar(y_prime(1),z_prime(1)),
5301 c      & " zz",scalar(z_prime(1),z_prime(1))
5302 c
5303 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5304 C to local coordinate system. Store in xx, yy, zz.
5305 c
5306         xx=0.0d0
5307         yy=0.0d0
5308         zz=0.0d0
5309         do j = 1,3
5310           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5311           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5312           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5313         enddo
5314
5315         xxtab(i)=xx
5316         yytab(i)=yy
5317         zztab(i)=zz
5318 C
5319 C Compute the energy of the ith side cbain
5320 C
5321 c        write (2,*) "xx",xx," yy",yy," zz",zz
5322         it=iabs(itype(i))
5323         do j = 1,65
5324           x(j) = sc_parmin(j,it)
5325         enddo
5326 #ifdef CHECK_COORD
5327 Cc diagnostics - remove later
5328         xx1 = dcos(alph(2))
5329         yy1 = dsin(alph(2))*dcos(omeg(2))
5330         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5331         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5332      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5333      &    xx1,yy1,zz1
5334 C,"  --- ", xx_w,yy_w,zz_w
5335 c end diagnostics
5336 #endif
5337         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5338      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5339      &   + x(10)*yy*zz
5340         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5341      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5342      & + x(20)*yy*zz
5343         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5344      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5345      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5346      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5347      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5348      &  +x(40)*xx*yy*zz
5349         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5350      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5351      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5352      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5353      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5354      &  +x(60)*xx*yy*zz
5355         dsc_i   = 0.743d0+x(61)
5356         dp2_i   = 1.9d0+x(62)
5357         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5358      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5359         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5360      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5361         s1=(1+x(63))/(0.1d0 + dscp1)
5362         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5363         s2=(1+x(65))/(0.1d0 + dscp2)
5364         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5365         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5366      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5367 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5368 c     &   sumene4,
5369 c     &   dscp1,dscp2,sumene
5370 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5371         escloc = escloc + sumene
5372 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5373 c     & ,zz,xx,yy
5374 c#define DEBUG
5375 #ifdef DEBUG
5376 C
5377 C This section to check the numerical derivatives of the energy of ith side
5378 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5379 C #define DEBUG in the code to turn it on.
5380 C
5381         write (2,*) "sumene               =",sumene
5382         aincr=1.0d-7
5383         xxsave=xx
5384         xx=xx+aincr
5385         write (2,*) xx,yy,zz
5386         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5387         de_dxx_num=(sumenep-sumene)/aincr
5388         xx=xxsave
5389         write (2,*) "xx+ sumene from enesc=",sumenep
5390         yysave=yy
5391         yy=yy+aincr
5392         write (2,*) xx,yy,zz
5393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         de_dyy_num=(sumenep-sumene)/aincr
5395         yy=yysave
5396         write (2,*) "yy+ sumene from enesc=",sumenep
5397         zzsave=zz
5398         zz=zz+aincr
5399         write (2,*) xx,yy,zz
5400         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5401         de_dzz_num=(sumenep-sumene)/aincr
5402         zz=zzsave
5403         write (2,*) "zz+ sumene from enesc=",sumenep
5404         costsave=cost2tab(i+1)
5405         sintsave=sint2tab(i+1)
5406         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5407         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5408         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5409         de_dt_num=(sumenep-sumene)/aincr
5410         write (2,*) " t+ sumene from enesc=",sumenep
5411         cost2tab(i+1)=costsave
5412         sint2tab(i+1)=sintsave
5413 C End of diagnostics section.
5414 #endif
5415 C
5416 C Compute the gradient of esc
5417 C
5418 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5419         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5420         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5421         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5422         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5423         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5424         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5425         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5426         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5427         pom1=(sumene3*sint2tab(i+1)+sumene1)
5428      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5429         pom2=(sumene4*cost2tab(i+1)+sumene2)
5430      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5431         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5432         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5433      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5434      &  +x(40)*yy*zz
5435         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5436         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5437      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5438      &  +x(60)*yy*zz
5439         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5440      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5441      &        +(pom1+pom2)*pom_dx
5442 #ifdef DEBUG
5443         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5444 #endif
5445 C
5446         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5447         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5448      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5449      &  +x(40)*xx*zz
5450         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5451         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5452      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5453      &  +x(59)*zz**2 +x(60)*xx*zz
5454         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5455      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5456      &        +(pom1-pom2)*pom_dy
5457 #ifdef DEBUG
5458         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5459 #endif
5460 C
5461         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5462      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5463      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5464      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5465      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5466      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5467      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5468      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5469 #ifdef DEBUG
5470         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5471 #endif
5472 C
5473         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5474      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5475      &  +pom1*pom_dt1+pom2*pom_dt2
5476 #ifdef DEBUG
5477         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5478 #endif
5479 c#undef DEBUG
5480 c
5481 C
5482        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5483        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5484        cosfac2xx=cosfac2*xx
5485        sinfac2yy=sinfac2*yy
5486        do k = 1,3
5487          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5488      &      vbld_inv(i+1)
5489          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5490      &      vbld_inv(i)
5491          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5492          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5493 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5494 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5495 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5496 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5497          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5498          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5499          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5500          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5501          dZZ_Ci1(k)=0.0d0
5502          dZZ_Ci(k)=0.0d0
5503          do j=1,3
5504            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5505      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5506            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5507      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5508          enddo
5509
5510          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5511          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5512          dZZ_XYZ(k)=vbld_inv(i+nres)*
5513      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5514 c
5515          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5516          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5517        enddo
5518
5519        do k=1,3
5520          dXX_Ctab(k,i)=dXX_Ci(k)
5521          dXX_C1tab(k,i)=dXX_Ci1(k)
5522          dYY_Ctab(k,i)=dYY_Ci(k)
5523          dYY_C1tab(k,i)=dYY_Ci1(k)
5524          dZZ_Ctab(k,i)=dZZ_Ci(k)
5525          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5526          dXX_XYZtab(k,i)=dXX_XYZ(k)
5527          dYY_XYZtab(k,i)=dYY_XYZ(k)
5528          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5529        enddo
5530
5531        do k = 1,3
5532 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5533 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5534 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5535 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5536 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5537 c     &    dt_dci(k)
5538 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5539 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5540          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5541      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5542          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5543      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5544          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5545      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5546        enddo
5547 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5548 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5549
5550 C to check gradient call subroutine check_grad
5551
5552     1 continue
5553       enddo
5554       return
5555       end
5556 c------------------------------------------------------------------------------
5557       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5558       implicit none
5559       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5560      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5561       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5562      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5563      &   + x(10)*yy*zz
5564       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5565      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5566      & + x(20)*yy*zz
5567       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5568      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5569      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5570      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5571      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5572      &  +x(40)*xx*yy*zz
5573       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5574      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5575      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5576      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5577      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5578      &  +x(60)*xx*yy*zz
5579       dsc_i   = 0.743d0+x(61)
5580       dp2_i   = 1.9d0+x(62)
5581       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5582      &          *(xx*cost2+yy*sint2))
5583       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5584      &          *(xx*cost2-yy*sint2))
5585       s1=(1+x(63))/(0.1d0 + dscp1)
5586       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5587       s2=(1+x(65))/(0.1d0 + dscp2)
5588       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5589       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5590      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5591       enesc=sumene
5592       return
5593       end
5594 #endif
5595 c------------------------------------------------------------------------------
5596       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5597 C
5598 C This procedure calculates two-body contact function g(rij) and its derivative:
5599 C
5600 C           eps0ij                                     !       x < -1
5601 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5602 C            0                                         !       x > 1
5603 C
5604 C where x=(rij-r0ij)/delta
5605 C
5606 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5607 C
5608       implicit none
5609       double precision rij,r0ij,eps0ij,fcont,fprimcont
5610       double precision x,x2,x4,delta
5611 c     delta=0.02D0*r0ij
5612 c      delta=0.2D0*r0ij
5613       x=(rij-r0ij)/delta
5614       if (x.lt.-1.0D0) then
5615         fcont=eps0ij
5616         fprimcont=0.0D0
5617       else if (x.le.1.0D0) then
5618         x2=x*x
5619         x4=x2*x2
5620         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5621         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5622       else
5623         fcont=0.0D0
5624         fprimcont=0.0D0
5625       endif
5626       return
5627       end
5628 c------------------------------------------------------------------------------
5629       subroutine splinthet(theti,delta,ss,ssder)
5630       implicit real*8 (a-h,o-z)
5631       include 'DIMENSIONS'
5632       include 'COMMON.VAR'
5633       include 'COMMON.GEO'
5634       thetup=pi-delta
5635       thetlow=delta
5636       if (theti.gt.pipol) then
5637         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5638       else
5639         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5640         ssder=-ssder
5641       endif
5642       return
5643       end
5644 c------------------------------------------------------------------------------
5645       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5646       implicit none
5647       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5648       double precision ksi,ksi2,ksi3,a1,a2,a3
5649       a1=fprim0*delta/(f1-f0)
5650       a2=3.0d0-2.0d0*a1
5651       a3=a1-2.0d0
5652       ksi=(x-x0)/delta
5653       ksi2=ksi*ksi
5654       ksi3=ksi2*ksi
5655       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5656       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5657       return
5658       end
5659 c------------------------------------------------------------------------------
5660       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5661       implicit none
5662       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5663       double precision ksi,ksi2,ksi3,a1,a2,a3
5664       ksi=(x-x0)/delta
5665       ksi2=ksi*ksi
5666       ksi3=ksi2*ksi
5667       a1=fprim0x*delta
5668       a2=3*(f1x-f0x)-2*fprim0x*delta
5669       a3=fprim0x*delta-2*(f1x-f0x)
5670       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5671       return
5672       end
5673 C-----------------------------------------------------------------------------
5674 #ifdef CRYST_TOR
5675 C-----------------------------------------------------------------------------
5676       subroutine etor(etors,edihcnstr)
5677       implicit real*8 (a-h,o-z)
5678       include 'DIMENSIONS'
5679       include 'COMMON.VAR'
5680       include 'COMMON.GEO'
5681       include 'COMMON.LOCAL'
5682       include 'COMMON.TORSION'
5683       include 'COMMON.INTERACT'
5684       include 'COMMON.DERIV'
5685       include 'COMMON.CHAIN'
5686       include 'COMMON.NAMES'
5687       include 'COMMON.IOUNITS'
5688       include 'COMMON.FFIELD'
5689       include 'COMMON.TORCNSTR'
5690       include 'COMMON.CONTROL'
5691       logical lprn
5692 C Set lprn=.true. for debugging
5693       lprn=.false.
5694 c      lprn=.true.
5695       etors=0.0D0
5696       do i=iphi_start,iphi_end
5697       etors_ii=0.0D0
5698         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5699      &      .or. itype(i).eq.ntyp1) cycle
5700         itori=itortyp(itype(i-2))
5701         itori1=itortyp(itype(i-1))
5702         phii=phi(i)
5703         gloci=0.0D0
5704 C Proline-Proline pair is a special case...
5705         if (itori.eq.3 .and. itori1.eq.3) then
5706           if (phii.gt.-dwapi3) then
5707             cosphi=dcos(3*phii)
5708             fac=1.0D0/(1.0D0-cosphi)
5709             etorsi=v1(1,3,3)*fac
5710             etorsi=etorsi+etorsi
5711             etors=etors+etorsi-v1(1,3,3)
5712             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5713             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5714           endif
5715           do j=1,3
5716             v1ij=v1(j+1,itori,itori1)
5717             v2ij=v2(j+1,itori,itori1)
5718             cosphi=dcos(j*phii)
5719             sinphi=dsin(j*phii)
5720             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5721             if (energy_dec) etors_ii=etors_ii+
5722      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5723             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5724           enddo
5725         else
5726           do j=1,nterm_old
5727             v1ij=v1(j,itori,itori1)
5728             v2ij=v2(j,itori,itori1)
5729             cosphi=dcos(j*phii)
5730             sinphi=dsin(j*phii)
5731             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5732             if (energy_dec) etors_ii=etors_ii+
5733      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5734             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5735           enddo
5736         endif
5737         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5738              'etor',i,etors_ii
5739         if (lprn)
5740      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5741      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5742      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5743         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5744 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5745       enddo
5746 ! 6/20/98 - dihedral angle constraints
5747       edihcnstr=0.0d0
5748       do i=1,ndih_constr
5749         itori=idih_constr(i)
5750         phii=phi(itori)
5751         difi=phii-phi0(i)
5752         if (difi.gt.drange(i)) then
5753           difi=difi-drange(i)
5754           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5755           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5756         else if (difi.lt.-drange(i)) then
5757           difi=difi+drange(i)
5758           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5759           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5760         endif
5761 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5762 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5763       enddo
5764 !      write (iout,*) 'edihcnstr',edihcnstr
5765       return
5766       end
5767 c------------------------------------------------------------------------------
5768       subroutine etor_d(etors_d)
5769       etors_d=0.0d0
5770       return
5771       end
5772 c----------------------------------------------------------------------------
5773 #else
5774       subroutine etor(etors,edihcnstr)
5775       implicit real*8 (a-h,o-z)
5776       include 'DIMENSIONS'
5777       include 'COMMON.VAR'
5778       include 'COMMON.GEO'
5779       include 'COMMON.LOCAL'
5780       include 'COMMON.TORSION'
5781       include 'COMMON.INTERACT'
5782       include 'COMMON.DERIV'
5783       include 'COMMON.CHAIN'
5784       include 'COMMON.NAMES'
5785       include 'COMMON.IOUNITS'
5786       include 'COMMON.FFIELD'
5787       include 'COMMON.TORCNSTR'
5788       include 'COMMON.CONTROL'
5789       logical lprn
5790 C Set lprn=.true. for debugging
5791       lprn=.false.
5792 c     lprn=.true.
5793       etors=0.0D0
5794       do i=iphi_start,iphi_end
5795         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5796      &       .or. itype(i).eq.ntyp1) cycle
5797         etors_ii=0.0D0
5798          if (iabs(itype(i)).eq.20) then
5799          iblock=2
5800          else
5801          iblock=1
5802          endif
5803         itori=itortyp(itype(i-2))
5804         itori1=itortyp(itype(i-1))
5805         phii=phi(i)
5806         gloci=0.0D0
5807 C Regular cosine and sine terms
5808         do j=1,nterm(itori,itori1,iblock)
5809           v1ij=v1(j,itori,itori1,iblock)
5810           v2ij=v2(j,itori,itori1,iblock)
5811           cosphi=dcos(j*phii)
5812           sinphi=dsin(j*phii)
5813           etors=etors+v1ij*cosphi+v2ij*sinphi
5814           if (energy_dec) etors_ii=etors_ii+
5815      &                v1ij*cosphi+v2ij*sinphi
5816           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5817         enddo
5818 C Lorentz terms
5819 C                         v1
5820 C  E = SUM ----------------------------------- - v1
5821 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5822 C
5823         cosphi=dcos(0.5d0*phii)
5824         sinphi=dsin(0.5d0*phii)
5825         do j=1,nlor(itori,itori1,iblock)
5826           vl1ij=vlor1(j,itori,itori1)
5827           vl2ij=vlor2(j,itori,itori1)
5828           vl3ij=vlor3(j,itori,itori1)
5829           pom=vl2ij*cosphi+vl3ij*sinphi
5830           pom1=1.0d0/(pom*pom+1.0d0)
5831           etors=etors+vl1ij*pom1
5832           if (energy_dec) etors_ii=etors_ii+
5833      &                vl1ij*pom1
5834           pom=-pom*pom1*pom1
5835           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5836         enddo
5837 C Subtract the constant term
5838         etors=etors-v0(itori,itori1,iblock)
5839           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5840      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5841         if (lprn)
5842      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5843      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5844      &  (v1(j,itori,itori1,iblock),j=1,6),
5845      &  (v2(j,itori,itori1,iblock),j=1,6)
5846         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5847 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5848       enddo
5849 ! 6/20/98 - dihedral angle constraints
5850       edihcnstr=0.0d0
5851 c      do i=1,ndih_constr
5852       do i=idihconstr_start,idihconstr_end
5853         itori=idih_constr(i)
5854         phii=phi(itori)
5855         difi=pinorm(phii-phi0(i))
5856         if (difi.gt.drange(i)) then
5857           difi=difi-drange(i)
5858           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5859           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5860         else if (difi.lt.-drange(i)) then
5861           difi=difi+drange(i)
5862           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5863           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5864         else
5865           difi=0.0
5866         endif
5867 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5868 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5869 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5870       enddo
5871 cd       write (iout,*) 'edihcnstr',edihcnstr
5872       return
5873       end
5874 c----------------------------------------------------------------------------
5875       subroutine etor_d(etors_d)
5876 C 6/23/01 Compute double torsional energy
5877       implicit real*8 (a-h,o-z)
5878       include 'DIMENSIONS'
5879       include 'COMMON.VAR'
5880       include 'COMMON.GEO'
5881       include 'COMMON.LOCAL'
5882       include 'COMMON.TORSION'
5883       include 'COMMON.INTERACT'
5884       include 'COMMON.DERIV'
5885       include 'COMMON.CHAIN'
5886       include 'COMMON.NAMES'
5887       include 'COMMON.IOUNITS'
5888       include 'COMMON.FFIELD'
5889       include 'COMMON.TORCNSTR'
5890       logical lprn
5891 C Set lprn=.true. for debugging
5892       lprn=.false.
5893 c     lprn=.true.
5894       etors_d=0.0D0
5895 c      write(iout,*) "a tu??"
5896       do i=iphid_start,iphid_end
5897         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5898      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5899         itori=itortyp(itype(i-2))
5900         itori1=itortyp(itype(i-1))
5901         itori2=itortyp(itype(i))
5902         phii=phi(i)
5903         phii1=phi(i+1)
5904         gloci1=0.0D0
5905         gloci2=0.0D0
5906         iblock=1
5907         if (iabs(itype(i+1)).eq.20) iblock=2
5908
5909 C Regular cosine and sine terms
5910         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5911           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5912           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5913           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5914           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5915           cosphi1=dcos(j*phii)
5916           sinphi1=dsin(j*phii)
5917           cosphi2=dcos(j*phii1)
5918           sinphi2=dsin(j*phii1)
5919           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5920      &     v2cij*cosphi2+v2sij*sinphi2
5921           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5922           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5923         enddo
5924         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5925           do l=1,k-1
5926             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5927             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5928             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5929             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5930             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5931             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5932             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5933             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5934             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5935      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5936             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5937      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5938             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5939      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5940           enddo
5941         enddo
5942         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5943         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5944       enddo
5945       return
5946       end
5947 #endif
5948 c------------------------------------------------------------------------------
5949       subroutine eback_sc_corr(esccor)
5950 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5951 c        conformational states; temporarily implemented as differences
5952 c        between UNRES torsional potentials (dependent on three types of
5953 c        residues) and the torsional potentials dependent on all 20 types
5954 c        of residues computed from AM1  energy surfaces of terminally-blocked
5955 c        amino-acid residues.
5956       implicit real*8 (a-h,o-z)
5957       include 'DIMENSIONS'
5958       include 'COMMON.VAR'
5959       include 'COMMON.GEO'
5960       include 'COMMON.LOCAL'
5961       include 'COMMON.TORSION'
5962       include 'COMMON.SCCOR'
5963       include 'COMMON.INTERACT'
5964       include 'COMMON.DERIV'
5965       include 'COMMON.CHAIN'
5966       include 'COMMON.NAMES'
5967       include 'COMMON.IOUNITS'
5968       include 'COMMON.FFIELD'
5969       include 'COMMON.CONTROL'
5970       logical lprn
5971 C Set lprn=.true. for debugging
5972       lprn=.false.
5973 c      lprn=.true.
5974 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5975       esccor=0.0D0
5976       do i=itau_start,itau_end
5977         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5978         esccor_ii=0.0D0
5979         isccori=isccortyp(itype(i-2))
5980         isccori1=isccortyp(itype(i-1))
5981 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5982         phii=phi(i)
5983         do intertyp=1,3 !intertyp
5984 cc Added 09 May 2012 (Adasko)
5985 cc  Intertyp means interaction type of backbone mainchain correlation:
5986 c   1 = SC...Ca...Ca...Ca
5987 c   2 = Ca...Ca...Ca...SC
5988 c   3 = SC...Ca...Ca...SCi
5989         gloci=0.0D0
5990         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5991      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5992      &      (itype(i-1).eq.ntyp1)))
5993      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5994      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5995      &     .or.(itype(i).eq.ntyp1)))
5996      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5997      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5998      &      (itype(i-3).eq.ntyp1)))) cycle
5999         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6000         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6001      & cycle
6002        do j=1,nterm_sccor(isccori,isccori1)
6003           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6004           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6005           cosphi=dcos(j*tauangle(intertyp,i))
6006           sinphi=dsin(j*tauangle(intertyp,i))
6007           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6008           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6009         enddo
6010 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6011         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6012         if (lprn)
6013      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6014      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6015      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6016      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6017         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6018        enddo !intertyp
6019       enddo
6020
6021       return
6022       end
6023 c----------------------------------------------------------------------------
6024       subroutine multibody(ecorr)
6025 C This subroutine calculates multi-body contributions to energy following
6026 C the idea of Skolnick et al. If side chains I and J make a contact and
6027 C at the same time side chains I+1 and J+1 make a contact, an extra
6028 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6029       implicit real*8 (a-h,o-z)
6030       include 'DIMENSIONS'
6031       include 'COMMON.IOUNITS'
6032       include 'COMMON.DERIV'
6033       include 'COMMON.INTERACT'
6034       include 'COMMON.CONTACTS'
6035       double precision gx(3),gx1(3)
6036       logical lprn
6037
6038 C Set lprn=.true. for debugging
6039       lprn=.false.
6040
6041       if (lprn) then
6042         write (iout,'(a)') 'Contact function values:'
6043         do i=nnt,nct-2
6044           write (iout,'(i2,20(1x,i2,f10.5))')
6045      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6046         enddo
6047       endif
6048       ecorr=0.0D0
6049       do i=nnt,nct
6050         do j=1,3
6051           gradcorr(j,i)=0.0D0
6052           gradxorr(j,i)=0.0D0
6053         enddo
6054       enddo
6055       do i=nnt,nct-2
6056
6057         DO ISHIFT = 3,4
6058
6059         i1=i+ishift
6060         num_conti=num_cont(i)
6061         num_conti1=num_cont(i1)
6062         do jj=1,num_conti
6063           j=jcont(jj,i)
6064           do kk=1,num_conti1
6065             j1=jcont(kk,i1)
6066             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6067 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6068 cd   &                   ' ishift=',ishift
6069 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6070 C The system gains extra energy.
6071               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6072             endif   ! j1==j+-ishift
6073           enddo     ! kk
6074         enddo       ! jj
6075
6076         ENDDO ! ISHIFT
6077
6078       enddo         ! i
6079       return
6080       end
6081 c------------------------------------------------------------------------------
6082       double precision function esccorr(i,j,k,l,jj,kk)
6083       implicit real*8 (a-h,o-z)
6084       include 'DIMENSIONS'
6085       include 'COMMON.IOUNITS'
6086       include 'COMMON.DERIV'
6087       include 'COMMON.INTERACT'
6088       include 'COMMON.CONTACTS'
6089       double precision gx(3),gx1(3)
6090       logical lprn
6091       lprn=.false.
6092       eij=facont(jj,i)
6093       ekl=facont(kk,k)
6094 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6095 C Calculate the multi-body contribution to energy.
6096 C Calculate multi-body contributions to the gradient.
6097 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6098 cd   & k,l,(gacont(m,kk,k),m=1,3)
6099       do m=1,3
6100         gx(m) =ekl*gacont(m,jj,i)
6101         gx1(m)=eij*gacont(m,kk,k)
6102         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6103         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6104         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6105         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6106       enddo
6107       do m=i,j-1
6108         do ll=1,3
6109           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6110         enddo
6111       enddo
6112       do m=k,l-1
6113         do ll=1,3
6114           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6115         enddo
6116       enddo
6117       esccorr=-eij*ekl
6118       return
6119       end
6120 c------------------------------------------------------------------------------
6121       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6122 C This subroutine calculates multi-body contributions to hydrogen-bonding
6123       implicit real*8 (a-h,o-z)
6124       include 'DIMENSIONS'
6125       include 'COMMON.IOUNITS'
6126 #ifdef MPI
6127       include "mpif.h"
6128       parameter (max_cont=maxconts)
6129       parameter (max_dim=26)
6130       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6131       double precision zapas(max_dim,maxconts,max_fg_procs),
6132      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6133       common /przechowalnia/ zapas
6134       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6135      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6136 #endif
6137       include 'COMMON.SETUP'
6138       include 'COMMON.FFIELD'
6139       include 'COMMON.DERIV'
6140       include 'COMMON.INTERACT'
6141       include 'COMMON.CONTACTS'
6142       include 'COMMON.CONTROL'
6143       include 'COMMON.LOCAL'
6144       double precision gx(3),gx1(3),time00
6145       logical lprn,ldone
6146
6147 C Set lprn=.true. for debugging
6148       lprn=.false.
6149 #ifdef MPI
6150       n_corr=0
6151       n_corr1=0
6152       if (nfgtasks.le.1) goto 30
6153       if (lprn) then
6154         write (iout,'(a)') 'Contact function values before RECEIVE:'
6155         do i=nnt,nct-2
6156           write (iout,'(2i3,50(1x,i2,f5.2))')
6157      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6158      &    j=1,num_cont_hb(i))
6159         enddo
6160       endif
6161       call flush(iout)
6162       do i=1,ntask_cont_from
6163         ncont_recv(i)=0
6164       enddo
6165       do i=1,ntask_cont_to
6166         ncont_sent(i)=0
6167       enddo
6168 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6169 c     & ntask_cont_to
6170 C Make the list of contacts to send to send to other procesors
6171 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6172 c      call flush(iout)
6173       do i=iturn3_start,iturn3_end
6174 c        write (iout,*) "make contact list turn3",i," num_cont",
6175 c     &    num_cont_hb(i)
6176         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6177       enddo
6178       do i=iturn4_start,iturn4_end
6179 c        write (iout,*) "make contact list turn4",i," num_cont",
6180 c     &   num_cont_hb(i)
6181         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6182       enddo
6183       do ii=1,nat_sent
6184         i=iat_sent(ii)
6185 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6186 c     &    num_cont_hb(i)
6187         do j=1,num_cont_hb(i)
6188         do k=1,4
6189           jjc=jcont_hb(j,i)
6190           iproc=iint_sent_local(k,jjc,ii)
6191 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6192           if (iproc.gt.0) then
6193             ncont_sent(iproc)=ncont_sent(iproc)+1
6194             nn=ncont_sent(iproc)
6195             zapas(1,nn,iproc)=i
6196             zapas(2,nn,iproc)=jjc
6197             zapas(3,nn,iproc)=facont_hb(j,i)
6198             zapas(4,nn,iproc)=ees0p(j,i)
6199             zapas(5,nn,iproc)=ees0m(j,i)
6200             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6201             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6202             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6203             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6204             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6205             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6206             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6207             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6208             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6209             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6210             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6211             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6212             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6213             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6214             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6215             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6216             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6217             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6218             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6219             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6220             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6221           endif
6222         enddo
6223         enddo
6224       enddo
6225       if (lprn) then
6226       write (iout,*)
6227      &  "Numbers of contacts to be sent to other processors",
6228      &  (ncont_sent(i),i=1,ntask_cont_to)
6229       write (iout,*) "Contacts sent"
6230       do ii=1,ntask_cont_to
6231         nn=ncont_sent(ii)
6232         iproc=itask_cont_to(ii)
6233         write (iout,*) nn," contacts to processor",iproc,
6234      &   " of CONT_TO_COMM group"
6235         do i=1,nn
6236           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6237         enddo
6238       enddo
6239       call flush(iout)
6240       endif
6241       CorrelType=477
6242       CorrelID=fg_rank+1
6243       CorrelType1=478
6244       CorrelID1=nfgtasks+fg_rank+1
6245       ireq=0
6246 C Receive the numbers of needed contacts from other processors
6247       do ii=1,ntask_cont_from
6248         iproc=itask_cont_from(ii)
6249         ireq=ireq+1
6250         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6251      &    FG_COMM,req(ireq),IERR)
6252       enddo
6253 c      write (iout,*) "IRECV ended"
6254 c      call flush(iout)
6255 C Send the number of contacts needed by other processors
6256       do ii=1,ntask_cont_to
6257         iproc=itask_cont_to(ii)
6258         ireq=ireq+1
6259         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6260      &    FG_COMM,req(ireq),IERR)
6261       enddo
6262 c      write (iout,*) "ISEND ended"
6263 c      write (iout,*) "number of requests (nn)",ireq
6264       call flush(iout)
6265       if (ireq.gt.0)
6266      &  call MPI_Waitall(ireq,req,status_array,ierr)
6267 c      write (iout,*)
6268 c     &  "Numbers of contacts to be received from other processors",
6269 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6270 c      call flush(iout)
6271 C Receive contacts
6272       ireq=0
6273       do ii=1,ntask_cont_from
6274         iproc=itask_cont_from(ii)
6275         nn=ncont_recv(ii)
6276 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6277 c     &   " of CONT_TO_COMM group"
6278         call flush(iout)
6279         if (nn.gt.0) then
6280           ireq=ireq+1
6281           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6282      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6283 c          write (iout,*) "ireq,req",ireq,req(ireq)
6284         endif
6285       enddo
6286 C Send the contacts to processors that need them
6287       do ii=1,ntask_cont_to
6288         iproc=itask_cont_to(ii)
6289         nn=ncont_sent(ii)
6290 c        write (iout,*) nn," contacts to processor",iproc,
6291 c     &   " of CONT_TO_COMM group"
6292         if (nn.gt.0) then
6293           ireq=ireq+1
6294           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6295      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6296 c          write (iout,*) "ireq,req",ireq,req(ireq)
6297 c          do i=1,nn
6298 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6299 c          enddo
6300         endif
6301       enddo
6302 c      write (iout,*) "number of requests (contacts)",ireq
6303 c      write (iout,*) "req",(req(i),i=1,4)
6304 c      call flush(iout)
6305       if (ireq.gt.0)
6306      & call MPI_Waitall(ireq,req,status_array,ierr)
6307       do iii=1,ntask_cont_from
6308         iproc=itask_cont_from(iii)
6309         nn=ncont_recv(iii)
6310         if (lprn) then
6311         write (iout,*) "Received",nn," contacts from processor",iproc,
6312      &   " of CONT_FROM_COMM group"
6313         call flush(iout)
6314         do i=1,nn
6315           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6316         enddo
6317         call flush(iout)
6318         endif
6319         do i=1,nn
6320           ii=zapas_recv(1,i,iii)
6321 c Flag the received contacts to prevent double-counting
6322           jj=-zapas_recv(2,i,iii)
6323 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6324 c          call flush(iout)
6325           nnn=num_cont_hb(ii)+1
6326           num_cont_hb(ii)=nnn
6327           jcont_hb(nnn,ii)=jj
6328           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6329           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6330           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6331           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6332           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6333           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6334           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6335           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6336           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6337           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6338           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6339           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6340           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6341           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6342           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6343           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6344           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6345           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6346           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6347           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6348           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6349           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6350           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6351           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6352         enddo
6353       enddo
6354       call flush(iout)
6355       if (lprn) then
6356         write (iout,'(a)') 'Contact function values after receive:'
6357         do i=nnt,nct-2
6358           write (iout,'(2i3,50(1x,i3,f5.2))')
6359      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6360      &    j=1,num_cont_hb(i))
6361         enddo
6362         call flush(iout)
6363       endif
6364    30 continue
6365 #endif
6366       if (lprn) then
6367         write (iout,'(a)') 'Contact function values:'
6368         do i=nnt,nct-2
6369           write (iout,'(2i3,50(1x,i3,f5.2))')
6370      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6371      &    j=1,num_cont_hb(i))
6372         enddo
6373       endif
6374       ecorr=0.0D0
6375 C Remove the loop below after debugging !!!
6376       do i=nnt,nct
6377         do j=1,3
6378           gradcorr(j,i)=0.0D0
6379           gradxorr(j,i)=0.0D0
6380         enddo
6381       enddo
6382 C Calculate the local-electrostatic correlation terms
6383       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6384         i1=i+1
6385         num_conti=num_cont_hb(i)
6386         num_conti1=num_cont_hb(i+1)
6387         do jj=1,num_conti
6388           j=jcont_hb(jj,i)
6389           jp=iabs(j)
6390           do kk=1,num_conti1
6391             j1=jcont_hb(kk,i1)
6392             jp1=iabs(j1)
6393 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6394 c     &         ' jj=',jj,' kk=',kk
6395             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6396      &          .or. j.lt.0 .and. j1.gt.0) .and.
6397      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6398 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6399 C The system gains extra energy.
6400               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6401               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6402      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6403               n_corr=n_corr+1
6404             else if (j1.eq.j) then
6405 C Contacts I-J and I-(J+1) occur simultaneously.
6406 C The system loses extra energy.
6407 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6408             endif
6409           enddo ! kk
6410           do kk=1,num_conti
6411             j1=jcont_hb(kk,i)
6412 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6413 c    &         ' jj=',jj,' kk=',kk
6414             if (j1.eq.j+1) then
6415 C Contacts I-J and (I+1)-J occur simultaneously.
6416 C The system loses extra energy.
6417 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6418             endif ! j1==j+1
6419           enddo ! kk
6420         enddo ! jj
6421       enddo ! i
6422       return
6423       end
6424 c------------------------------------------------------------------------------
6425       subroutine add_hb_contact(ii,jj,itask)
6426       implicit real*8 (a-h,o-z)
6427       include "DIMENSIONS"
6428       include "COMMON.IOUNITS"
6429       integer max_cont
6430       integer max_dim
6431       parameter (max_cont=maxconts)
6432       parameter (max_dim=26)
6433       include "COMMON.CONTACTS"
6434       double precision zapas(max_dim,maxconts,max_fg_procs),
6435      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6436       common /przechowalnia/ zapas
6437       integer i,j,ii,jj,iproc,itask(4),nn
6438 c      write (iout,*) "itask",itask
6439       do i=1,2
6440         iproc=itask(i)
6441         if (iproc.gt.0) then
6442           do j=1,num_cont_hb(ii)
6443             jjc=jcont_hb(j,ii)
6444 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6445             if (jjc.eq.jj) then
6446               ncont_sent(iproc)=ncont_sent(iproc)+1
6447               nn=ncont_sent(iproc)
6448               zapas(1,nn,iproc)=ii
6449               zapas(2,nn,iproc)=jjc
6450               zapas(3,nn,iproc)=facont_hb(j,ii)
6451               zapas(4,nn,iproc)=ees0p(j,ii)
6452               zapas(5,nn,iproc)=ees0m(j,ii)
6453               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6454               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6455               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6456               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6457               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6458               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6459               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6460               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6461               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6462               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6463               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6464               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6465               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6466               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6467               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6468               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6469               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6470               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6471               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6472               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6473               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6474               exit
6475             endif
6476           enddo
6477         endif
6478       enddo
6479       return
6480       end
6481 c------------------------------------------------------------------------------
6482       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6483      &  n_corr1)
6484 C This subroutine calculates multi-body contributions to hydrogen-bonding
6485       implicit real*8 (a-h,o-z)
6486       include 'DIMENSIONS'
6487       include 'COMMON.IOUNITS'
6488 #ifdef MPI
6489       include "mpif.h"
6490       parameter (max_cont=maxconts)
6491       parameter (max_dim=70)
6492       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6493       double precision zapas(max_dim,maxconts,max_fg_procs),
6494      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6495       common /przechowalnia/ zapas
6496       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6497      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6498 #endif
6499       include 'COMMON.SETUP'
6500       include 'COMMON.FFIELD'
6501       include 'COMMON.DERIV'
6502       include 'COMMON.LOCAL'
6503       include 'COMMON.INTERACT'
6504       include 'COMMON.CONTACTS'
6505       include 'COMMON.CHAIN'
6506       include 'COMMON.CONTROL'
6507       double precision gx(3),gx1(3)
6508       integer num_cont_hb_old(maxres)
6509       logical lprn,ldone
6510       double precision eello4,eello5,eelo6,eello_turn6
6511       external eello4,eello5,eello6,eello_turn6
6512 C Set lprn=.true. for debugging
6513       lprn=.false.
6514       eturn6=0.0d0
6515 #ifdef MPI
6516       do i=1,nres
6517         num_cont_hb_old(i)=num_cont_hb(i)
6518       enddo
6519       n_corr=0
6520       n_corr1=0
6521       if (nfgtasks.le.1) goto 30
6522       if (lprn) then
6523         write (iout,'(a)') 'Contact function values before RECEIVE:'
6524         do i=nnt,nct-2
6525           write (iout,'(2i3,50(1x,i2,f5.2))')
6526      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6527      &    j=1,num_cont_hb(i))
6528         enddo
6529       endif
6530       call flush(iout)
6531       do i=1,ntask_cont_from
6532         ncont_recv(i)=0
6533       enddo
6534       do i=1,ntask_cont_to
6535         ncont_sent(i)=0
6536       enddo
6537 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6538 c     & ntask_cont_to
6539 C Make the list of contacts to send to send to other procesors
6540       do i=iturn3_start,iturn3_end
6541 c        write (iout,*) "make contact list turn3",i," num_cont",
6542 c     &    num_cont_hb(i)
6543         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6544       enddo
6545       do i=iturn4_start,iturn4_end
6546 c        write (iout,*) "make contact list turn4",i," num_cont",
6547 c     &   num_cont_hb(i)
6548         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6549       enddo
6550       do ii=1,nat_sent
6551         i=iat_sent(ii)
6552 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6553 c     &    num_cont_hb(i)
6554         do j=1,num_cont_hb(i)
6555         do k=1,4
6556           jjc=jcont_hb(j,i)
6557           iproc=iint_sent_local(k,jjc,ii)
6558 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6559           if (iproc.ne.0) then
6560             ncont_sent(iproc)=ncont_sent(iproc)+1
6561             nn=ncont_sent(iproc)
6562             zapas(1,nn,iproc)=i
6563             zapas(2,nn,iproc)=jjc
6564             zapas(3,nn,iproc)=d_cont(j,i)
6565             ind=3
6566             do kk=1,3
6567               ind=ind+1
6568               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6569             enddo
6570             do kk=1,2
6571               do ll=1,2
6572                 ind=ind+1
6573                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6574               enddo
6575             enddo
6576             do jj=1,5
6577               do kk=1,3
6578                 do ll=1,2
6579                   do mm=1,2
6580                     ind=ind+1
6581                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6582                   enddo
6583                 enddo
6584               enddo
6585             enddo
6586           endif
6587         enddo
6588         enddo
6589       enddo
6590       if (lprn) then
6591       write (iout,*)
6592      &  "Numbers of contacts to be sent to other processors",
6593      &  (ncont_sent(i),i=1,ntask_cont_to)
6594       write (iout,*) "Contacts sent"
6595       do ii=1,ntask_cont_to
6596         nn=ncont_sent(ii)
6597         iproc=itask_cont_to(ii)
6598         write (iout,*) nn," contacts to processor",iproc,
6599      &   " of CONT_TO_COMM group"
6600         do i=1,nn
6601           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6602         enddo
6603       enddo
6604       call flush(iout)
6605       endif
6606       CorrelType=477
6607       CorrelID=fg_rank+1
6608       CorrelType1=478
6609       CorrelID1=nfgtasks+fg_rank+1
6610       ireq=0
6611 C Receive the numbers of needed contacts from other processors
6612       do ii=1,ntask_cont_from
6613         iproc=itask_cont_from(ii)
6614         ireq=ireq+1
6615         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6616      &    FG_COMM,req(ireq),IERR)
6617       enddo
6618 c      write (iout,*) "IRECV ended"
6619 c      call flush(iout)
6620 C Send the number of contacts needed by other processors
6621       do ii=1,ntask_cont_to
6622         iproc=itask_cont_to(ii)
6623         ireq=ireq+1
6624         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6625      &    FG_COMM,req(ireq),IERR)
6626       enddo
6627 c      write (iout,*) "ISEND ended"
6628 c      write (iout,*) "number of requests (nn)",ireq
6629       call flush(iout)
6630       if (ireq.gt.0)
6631      &  call MPI_Waitall(ireq,req,status_array,ierr)
6632 c      write (iout,*)
6633 c     &  "Numbers of contacts to be received from other processors",
6634 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6635 c      call flush(iout)
6636 C Receive contacts
6637       ireq=0
6638       do ii=1,ntask_cont_from
6639         iproc=itask_cont_from(ii)
6640         nn=ncont_recv(ii)
6641 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6642 c     &   " of CONT_TO_COMM group"
6643         call flush(iout)
6644         if (nn.gt.0) then
6645           ireq=ireq+1
6646           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6647      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6648 c          write (iout,*) "ireq,req",ireq,req(ireq)
6649         endif
6650       enddo
6651 C Send the contacts to processors that need them
6652       do ii=1,ntask_cont_to
6653         iproc=itask_cont_to(ii)
6654         nn=ncont_sent(ii)
6655 c        write (iout,*) nn," contacts to processor",iproc,
6656 c     &   " of CONT_TO_COMM group"
6657         if (nn.gt.0) then
6658           ireq=ireq+1
6659           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6660      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6661 c          write (iout,*) "ireq,req",ireq,req(ireq)
6662 c          do i=1,nn
6663 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6664 c          enddo
6665         endif
6666       enddo
6667 c      write (iout,*) "number of requests (contacts)",ireq
6668 c      write (iout,*) "req",(req(i),i=1,4)
6669 c      call flush(iout)
6670       if (ireq.gt.0)
6671      & call MPI_Waitall(ireq,req,status_array,ierr)
6672       do iii=1,ntask_cont_from
6673         iproc=itask_cont_from(iii)
6674         nn=ncont_recv(iii)
6675         if (lprn) then
6676         write (iout,*) "Received",nn," contacts from processor",iproc,
6677      &   " of CONT_FROM_COMM group"
6678         call flush(iout)
6679         do i=1,nn
6680           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6681         enddo
6682         call flush(iout)
6683         endif
6684         do i=1,nn
6685           ii=zapas_recv(1,i,iii)
6686 c Flag the received contacts to prevent double-counting
6687           jj=-zapas_recv(2,i,iii)
6688 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6689 c          call flush(iout)
6690           nnn=num_cont_hb(ii)+1
6691           num_cont_hb(ii)=nnn
6692           jcont_hb(nnn,ii)=jj
6693           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6694           ind=3
6695           do kk=1,3
6696             ind=ind+1
6697             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6698           enddo
6699           do kk=1,2
6700             do ll=1,2
6701               ind=ind+1
6702               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6703             enddo
6704           enddo
6705           do jj=1,5
6706             do kk=1,3
6707               do ll=1,2
6708                 do mm=1,2
6709                   ind=ind+1
6710                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6711                 enddo
6712               enddo
6713             enddo
6714           enddo
6715         enddo
6716       enddo
6717       call flush(iout)
6718       if (lprn) then
6719         write (iout,'(a)') 'Contact function values after receive:'
6720         do i=nnt,nct-2
6721           write (iout,'(2i3,50(1x,i3,5f6.3))')
6722      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6723      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6724         enddo
6725         call flush(iout)
6726       endif
6727    30 continue
6728 #endif
6729       if (lprn) then
6730         write (iout,'(a)') 'Contact function values:'
6731         do i=nnt,nct-2
6732           write (iout,'(2i3,50(1x,i2,5f6.3))')
6733      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6734      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6735         enddo
6736       endif
6737       ecorr=0.0D0
6738       ecorr5=0.0d0
6739       ecorr6=0.0d0
6740 C Remove the loop below after debugging !!!
6741       do i=nnt,nct
6742         do j=1,3
6743           gradcorr(j,i)=0.0D0
6744           gradxorr(j,i)=0.0D0
6745         enddo
6746       enddo
6747 C Calculate the dipole-dipole interaction energies
6748       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6749       do i=iatel_s,iatel_e+1
6750         num_conti=num_cont_hb(i)
6751         do jj=1,num_conti
6752           j=jcont_hb(jj,i)
6753 #ifdef MOMENT
6754           call dipole(i,j,jj)
6755 #endif
6756         enddo
6757       enddo
6758       endif
6759 C Calculate the local-electrostatic correlation terms
6760 c                write (iout,*) "gradcorr5 in eello5 before loop"
6761 c                do iii=1,nres
6762 c                  write (iout,'(i5,3f10.5)')
6763 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6764 c                enddo
6765       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6766 c        write (iout,*) "corr loop i",i
6767         i1=i+1
6768         num_conti=num_cont_hb(i)
6769         num_conti1=num_cont_hb(i+1)
6770         do jj=1,num_conti
6771           j=jcont_hb(jj,i)
6772           jp=iabs(j)
6773           do kk=1,num_conti1
6774             j1=jcont_hb(kk,i1)
6775             jp1=iabs(j1)
6776 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6777 c     &         ' jj=',jj,' kk=',kk
6778 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6779             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6780      &          .or. j.lt.0 .and. j1.gt.0) .and.
6781      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6782 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6783 C The system gains extra energy.
6784               n_corr=n_corr+1
6785               sqd1=dsqrt(d_cont(jj,i))
6786               sqd2=dsqrt(d_cont(kk,i1))
6787               sred_geom = sqd1*sqd2
6788               IF (sred_geom.lt.cutoff_corr) THEN
6789                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6790      &            ekont,fprimcont)
6791 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6792 cd     &         ' jj=',jj,' kk=',kk
6793                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6794                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6795                 do l=1,3
6796                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6797                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6798                 enddo
6799                 n_corr1=n_corr1+1
6800 cd               write (iout,*) 'sred_geom=',sred_geom,
6801 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6802 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6803 cd               write (iout,*) "g_contij",g_contij
6804 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6805 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6806                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6807                 if (wcorr4.gt.0.0d0)
6808      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6809                   if (energy_dec.and.wcorr4.gt.0.0d0)
6810      1                 write (iout,'(a6,4i5,0pf7.3)')
6811      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6812 c                write (iout,*) "gradcorr5 before eello5"
6813 c                do iii=1,nres
6814 c                  write (iout,'(i5,3f10.5)')
6815 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6816 c                enddo
6817                 if (wcorr5.gt.0.0d0)
6818      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6819 c                write (iout,*) "gradcorr5 after eello5"
6820 c                do iii=1,nres
6821 c                  write (iout,'(i5,3f10.5)')
6822 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6823 c                enddo
6824                   if (energy_dec.and.wcorr5.gt.0.0d0)
6825      1                 write (iout,'(a6,4i5,0pf7.3)')
6826      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6827 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6828 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6829                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6830      &               .or. wturn6.eq.0.0d0))then
6831 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6832                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6833                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6834      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6835 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6836 cd     &            'ecorr6=',ecorr6
6837 cd                write (iout,'(4e15.5)') sred_geom,
6838 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6839 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6840 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6841                 else if (wturn6.gt.0.0d0
6842      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6843 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6844                   eturn6=eturn6+eello_turn6(i,jj,kk)
6845                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6846      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6847 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6848                 endif
6849               ENDIF
6850 1111          continue
6851             endif
6852           enddo ! kk
6853         enddo ! jj
6854       enddo ! i
6855       do i=1,nres
6856         num_cont_hb(i)=num_cont_hb_old(i)
6857       enddo
6858 c                write (iout,*) "gradcorr5 in eello5"
6859 c                do iii=1,nres
6860 c                  write (iout,'(i5,3f10.5)')
6861 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6862 c                enddo
6863       return
6864       end
6865 c------------------------------------------------------------------------------
6866       subroutine add_hb_contact_eello(ii,jj,itask)
6867       implicit real*8 (a-h,o-z)
6868       include "DIMENSIONS"
6869       include "COMMON.IOUNITS"
6870       integer max_cont
6871       integer max_dim
6872       parameter (max_cont=maxconts)
6873       parameter (max_dim=70)
6874       include "COMMON.CONTACTS"
6875       double precision zapas(max_dim,maxconts,max_fg_procs),
6876      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6877       common /przechowalnia/ zapas
6878       integer i,j,ii,jj,iproc,itask(4),nn
6879 c      write (iout,*) "itask",itask
6880       do i=1,2
6881         iproc=itask(i)
6882         if (iproc.gt.0) then
6883           do j=1,num_cont_hb(ii)
6884             jjc=jcont_hb(j,ii)
6885 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6886             if (jjc.eq.jj) then
6887               ncont_sent(iproc)=ncont_sent(iproc)+1
6888               nn=ncont_sent(iproc)
6889               zapas(1,nn,iproc)=ii
6890               zapas(2,nn,iproc)=jjc
6891               zapas(3,nn,iproc)=d_cont(j,ii)
6892               ind=3
6893               do kk=1,3
6894                 ind=ind+1
6895                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6896               enddo
6897               do kk=1,2
6898                 do ll=1,2
6899                   ind=ind+1
6900                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6901                 enddo
6902               enddo
6903               do jj=1,5
6904                 do kk=1,3
6905                   do ll=1,2
6906                     do mm=1,2
6907                       ind=ind+1
6908                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6909                     enddo
6910                   enddo
6911                 enddo
6912               enddo
6913               exit
6914             endif
6915           enddo
6916         endif
6917       enddo
6918       return
6919       end
6920 c------------------------------------------------------------------------------
6921       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6922       implicit real*8 (a-h,o-z)
6923       include 'DIMENSIONS'
6924       include 'COMMON.IOUNITS'
6925       include 'COMMON.DERIV'
6926       include 'COMMON.INTERACT'
6927       include 'COMMON.CONTACTS'
6928       double precision gx(3),gx1(3)
6929       logical lprn
6930       lprn=.false.
6931       eij=facont_hb(jj,i)
6932       ekl=facont_hb(kk,k)
6933       ees0pij=ees0p(jj,i)
6934       ees0pkl=ees0p(kk,k)
6935       ees0mij=ees0m(jj,i)
6936       ees0mkl=ees0m(kk,k)
6937       ekont=eij*ekl
6938       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6939 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6940 C Following 4 lines for diagnostics.
6941 cd    ees0pkl=0.0D0
6942 cd    ees0pij=1.0D0
6943 cd    ees0mkl=0.0D0
6944 cd    ees0mij=1.0D0
6945 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6946 c     & 'Contacts ',i,j,
6947 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6948 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6949 c     & 'gradcorr_long'
6950 C Calculate the multi-body contribution to energy.
6951 c      ecorr=ecorr+ekont*ees
6952 C Calculate multi-body contributions to the gradient.
6953       coeffpees0pij=coeffp*ees0pij
6954       coeffmees0mij=coeffm*ees0mij
6955       coeffpees0pkl=coeffp*ees0pkl
6956       coeffmees0mkl=coeffm*ees0mkl
6957       do ll=1,3
6958 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6959         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6960      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6961      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6962         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6963      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6964      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6965 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6966         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6967      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6968      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6969         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6970      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6971      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6972         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6973      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6974      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6975         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6976         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6977         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6978      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6979      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6980         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6981         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6982 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6983       enddo
6984 c      write (iout,*)
6985 cgrad      do m=i+1,j-1
6986 cgrad        do ll=1,3
6987 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6988 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6989 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6990 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6991 cgrad        enddo
6992 cgrad      enddo
6993 cgrad      do m=k+1,l-1
6994 cgrad        do ll=1,3
6995 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6996 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6997 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6998 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6999 cgrad        enddo
7000 cgrad      enddo
7001 c      write (iout,*) "ehbcorr",ekont*ees
7002       ehbcorr=ekont*ees
7003       return
7004       end
7005 #ifdef MOMENT
7006 C---------------------------------------------------------------------------
7007       subroutine dipole(i,j,jj)
7008       implicit real*8 (a-h,o-z)
7009       include 'DIMENSIONS'
7010       include 'COMMON.IOUNITS'
7011       include 'COMMON.CHAIN'
7012       include 'COMMON.FFIELD'
7013       include 'COMMON.DERIV'
7014       include 'COMMON.INTERACT'
7015       include 'COMMON.CONTACTS'
7016       include 'COMMON.TORSION'
7017       include 'COMMON.VAR'
7018       include 'COMMON.GEO'
7019       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7020      &  auxmat(2,2)
7021       iti1 = itortyp(itype(i+1))
7022       if (j.lt.nres-1) then
7023         itj1 = itortyp(itype(j+1))
7024       else
7025         itj1=ntortyp+1
7026       endif
7027       do iii=1,2
7028         dipi(iii,1)=Ub2(iii,i)
7029         dipderi(iii)=Ub2der(iii,i)
7030         dipi(iii,2)=b1(iii,i+1)
7031         dipj(iii,1)=Ub2(iii,j)
7032         dipderj(iii)=Ub2der(iii,j)
7033         dipj(iii,2)=b1(iii,j+1)
7034       enddo
7035       kkk=0
7036       do iii=1,2
7037         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7038         do jjj=1,2
7039           kkk=kkk+1
7040           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7041         enddo
7042       enddo
7043       do kkk=1,5
7044         do lll=1,3
7045           mmm=0
7046           do iii=1,2
7047             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7048      &        auxvec(1))
7049             do jjj=1,2
7050               mmm=mmm+1
7051               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7052             enddo
7053           enddo
7054         enddo
7055       enddo
7056       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7057       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7058       do iii=1,2
7059         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7060       enddo
7061       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7062       do iii=1,2
7063         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7064       enddo
7065       return
7066       end
7067 #endif
7068 C---------------------------------------------------------------------------
7069       subroutine calc_eello(i,j,k,l,jj,kk)
7070 C
7071 C This subroutine computes matrices and vectors needed to calculate
7072 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7073 C
7074       implicit real*8 (a-h,o-z)
7075       include 'DIMENSIONS'
7076       include 'COMMON.IOUNITS'
7077       include 'COMMON.CHAIN'
7078       include 'COMMON.DERIV'
7079       include 'COMMON.INTERACT'
7080       include 'COMMON.CONTACTS'
7081       include 'COMMON.TORSION'
7082       include 'COMMON.VAR'
7083       include 'COMMON.GEO'
7084       include 'COMMON.FFIELD'
7085       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7086      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7087       logical lprn
7088       common /kutas/ lprn
7089 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7090 cd     & ' jj=',jj,' kk=',kk
7091 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7092 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7093 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7094       do iii=1,2
7095         do jjj=1,2
7096           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7097           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7098         enddo
7099       enddo
7100       call transpose2(aa1(1,1),aa1t(1,1))
7101       call transpose2(aa2(1,1),aa2t(1,1))
7102       do kkk=1,5
7103         do lll=1,3
7104           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7105      &      aa1tder(1,1,lll,kkk))
7106           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7107      &      aa2tder(1,1,lll,kkk))
7108         enddo
7109       enddo
7110       if (l.eq.j+1) then
7111 C parallel orientation of the two CA-CA-CA frames.
7112         if (i.gt.1) then
7113           iti=itortyp(itype(i))
7114         else
7115           iti=ntortyp+1
7116         endif
7117         itk1=itortyp(itype(k+1))
7118         itj=itortyp(itype(j))
7119         if (l.lt.nres-1) then
7120           itl1=itortyp(itype(l+1))
7121         else
7122           itl1=ntortyp+1
7123         endif
7124 C A1 kernel(j+1) A2T
7125 cd        do iii=1,2
7126 cd          write (iout,'(3f10.5,5x,3f10.5)')
7127 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7128 cd        enddo
7129         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7130      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7131      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7132 C Following matrices are needed only for 6-th order cumulants
7133         IF (wcorr6.gt.0.0d0) THEN
7134         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7135      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7136      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7137         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7138      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7139      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7140      &   ADtEAderx(1,1,1,1,1,1))
7141         lprn=.false.
7142         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7143      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7144      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7145      &   ADtEA1derx(1,1,1,1,1,1))
7146         ENDIF
7147 C End 6-th order cumulants
7148 cd        lprn=.false.
7149 cd        if (lprn) then
7150 cd        write (2,*) 'In calc_eello6'
7151 cd        do iii=1,2
7152 cd          write (2,*) 'iii=',iii
7153 cd          do kkk=1,5
7154 cd            write (2,*) 'kkk=',kkk
7155 cd            do jjj=1,2
7156 cd              write (2,'(3(2f10.5),5x)')
7157 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7158 cd            enddo
7159 cd          enddo
7160 cd        enddo
7161 cd        endif
7162         call transpose2(EUgder(1,1,k),auxmat(1,1))
7163         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7164         call transpose2(EUg(1,1,k),auxmat(1,1))
7165         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7166         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7167         do iii=1,2
7168           do kkk=1,5
7169             do lll=1,3
7170               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7171      &          EAEAderx(1,1,lll,kkk,iii,1))
7172             enddo
7173           enddo
7174         enddo
7175 C A1T kernel(i+1) A2
7176         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7177      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7178      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7179 C Following matrices are needed only for 6-th order cumulants
7180         IF (wcorr6.gt.0.0d0) THEN
7181         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7182      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7183      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7184         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7185      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7186      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7187      &   ADtEAderx(1,1,1,1,1,2))
7188         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7189      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7190      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7191      &   ADtEA1derx(1,1,1,1,1,2))
7192         ENDIF
7193 C End 6-th order cumulants
7194         call transpose2(EUgder(1,1,l),auxmat(1,1))
7195         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7196         call transpose2(EUg(1,1,l),auxmat(1,1))
7197         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7198         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7199         do iii=1,2
7200           do kkk=1,5
7201             do lll=1,3
7202               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7203      &          EAEAderx(1,1,lll,kkk,iii,2))
7204             enddo
7205           enddo
7206         enddo
7207 C AEAb1 and AEAb2
7208 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7209 C They are needed only when the fifth- or the sixth-order cumulants are
7210 C indluded.
7211         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7212         call transpose2(AEA(1,1,1),auxmat(1,1))
7213         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7214         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7215         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7216         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7217         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7218         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7219         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7220         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7221         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7222         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7223         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7224         call transpose2(AEA(1,1,2),auxmat(1,1))
7225         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7226         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7227         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7228         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7229         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7230         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7231         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7232         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7233         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7234         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7235         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7236 C Calculate the Cartesian derivatives of the vectors.
7237         do iii=1,2
7238           do kkk=1,5
7239             do lll=1,3
7240               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7241               call matvec2(auxmat(1,1),b1(1,i),
7242      &          AEAb1derx(1,lll,kkk,iii,1,1))
7243               call matvec2(auxmat(1,1),Ub2(1,i),
7244      &          AEAb2derx(1,lll,kkk,iii,1,1))
7245               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7246      &          AEAb1derx(1,lll,kkk,iii,2,1))
7247               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7248      &          AEAb2derx(1,lll,kkk,iii,2,1))
7249               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7250               call matvec2(auxmat(1,1),b1(1,j),
7251      &          AEAb1derx(1,lll,kkk,iii,1,2))
7252               call matvec2(auxmat(1,1),Ub2(1,j),
7253      &          AEAb2derx(1,lll,kkk,iii,1,2))
7254               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7255      &          AEAb1derx(1,lll,kkk,iii,2,2))
7256               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7257      &          AEAb2derx(1,lll,kkk,iii,2,2))
7258             enddo
7259           enddo
7260         enddo
7261         ENDIF
7262 C End vectors
7263       else
7264 C Antiparallel orientation of the two CA-CA-CA frames.
7265         if (i.gt.1) then
7266           iti=itortyp(itype(i))
7267         else
7268           iti=ntortyp+1
7269         endif
7270         itk1=itortyp(itype(k+1))
7271         itl=itortyp(itype(l))
7272         itj=itortyp(itype(j))
7273         if (j.lt.nres-1) then
7274           itj1=itortyp(itype(j+1))
7275         else
7276           itj1=ntortyp+1
7277         endif
7278 C A2 kernel(j-1)T A1T
7279         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7280      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7281      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7282 C Following matrices are needed only for 6-th order cumulants
7283         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7284      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7285         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7286      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7287      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7288         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7289      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7290      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7291      &   ADtEAderx(1,1,1,1,1,1))
7292         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7293      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7294      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7295      &   ADtEA1derx(1,1,1,1,1,1))
7296         ENDIF
7297 C End 6-th order cumulants
7298         call transpose2(EUgder(1,1,k),auxmat(1,1))
7299         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7300         call transpose2(EUg(1,1,k),auxmat(1,1))
7301         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7302         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7303         do iii=1,2
7304           do kkk=1,5
7305             do lll=1,3
7306               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7307      &          EAEAderx(1,1,lll,kkk,iii,1))
7308             enddo
7309           enddo
7310         enddo
7311 C A2T kernel(i+1)T A1
7312         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7313      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7314      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7315 C Following matrices are needed only for 6-th order cumulants
7316         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7317      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7318         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7319      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7320      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7321         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7322      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7323      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7324      &   ADtEAderx(1,1,1,1,1,2))
7325         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7326      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7327      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7328      &   ADtEA1derx(1,1,1,1,1,2))
7329         ENDIF
7330 C End 6-th order cumulants
7331         call transpose2(EUgder(1,1,j),auxmat(1,1))
7332         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7333         call transpose2(EUg(1,1,j),auxmat(1,1))
7334         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7335         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7336         do iii=1,2
7337           do kkk=1,5
7338             do lll=1,3
7339               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7340      &          EAEAderx(1,1,lll,kkk,iii,2))
7341             enddo
7342           enddo
7343         enddo
7344 C AEAb1 and AEAb2
7345 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7346 C They are needed only when the fifth- or the sixth-order cumulants are
7347 C indluded.
7348         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7349      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7350         call transpose2(AEA(1,1,1),auxmat(1,1))
7351         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7352         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7353         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7354         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7355         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7356         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7357         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7358         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7359         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7360         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7361         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7362         call transpose2(AEA(1,1,2),auxmat(1,1))
7363         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7364         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7365         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7366         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7367         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7368         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7369         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7370         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7371         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7372         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7373         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7374 C Calculate the Cartesian derivatives of the vectors.
7375         do iii=1,2
7376           do kkk=1,5
7377             do lll=1,3
7378               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7379               call matvec2(auxmat(1,1),b1(1,i),
7380      &          AEAb1derx(1,lll,kkk,iii,1,1))
7381               call matvec2(auxmat(1,1),Ub2(1,i),
7382      &          AEAb2derx(1,lll,kkk,iii,1,1))
7383               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7384      &          AEAb1derx(1,lll,kkk,iii,2,1))
7385               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7386      &          AEAb2derx(1,lll,kkk,iii,2,1))
7387               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7388               call matvec2(auxmat(1,1),b1(1,l),
7389      &          AEAb1derx(1,lll,kkk,iii,1,2))
7390               call matvec2(auxmat(1,1),Ub2(1,l),
7391      &          AEAb2derx(1,lll,kkk,iii,1,2))
7392               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7393      &          AEAb1derx(1,lll,kkk,iii,2,2))
7394               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7395      &          AEAb2derx(1,lll,kkk,iii,2,2))
7396             enddo
7397           enddo
7398         enddo
7399         ENDIF
7400 C End vectors
7401       endif
7402       return
7403       end
7404 C---------------------------------------------------------------------------
7405       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7406      &  KK,KKderg,AKA,AKAderg,AKAderx)
7407       implicit none
7408       integer nderg
7409       logical transp
7410       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7411      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7412      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7413       integer iii,kkk,lll
7414       integer jjj,mmm
7415       logical lprn
7416       common /kutas/ lprn
7417       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7418       do iii=1,nderg
7419         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7420      &    AKAderg(1,1,iii))
7421       enddo
7422 cd      if (lprn) write (2,*) 'In kernel'
7423       do kkk=1,5
7424 cd        if (lprn) write (2,*) 'kkk=',kkk
7425         do lll=1,3
7426           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7427      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7428 cd          if (lprn) then
7429 cd            write (2,*) 'lll=',lll
7430 cd            write (2,*) 'iii=1'
7431 cd            do jjj=1,2
7432 cd              write (2,'(3(2f10.5),5x)')
7433 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7434 cd            enddo
7435 cd          endif
7436           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7437      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7438 cd          if (lprn) then
7439 cd            write (2,*) 'lll=',lll
7440 cd            write (2,*) 'iii=2'
7441 cd            do jjj=1,2
7442 cd              write (2,'(3(2f10.5),5x)')
7443 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7444 cd            enddo
7445 cd          endif
7446         enddo
7447       enddo
7448       return
7449       end
7450 C---------------------------------------------------------------------------
7451       double precision function eello4(i,j,k,l,jj,kk)
7452       implicit real*8 (a-h,o-z)
7453       include 'DIMENSIONS'
7454       include 'COMMON.IOUNITS'
7455       include 'COMMON.CHAIN'
7456       include 'COMMON.DERIV'
7457       include 'COMMON.INTERACT'
7458       include 'COMMON.CONTACTS'
7459       include 'COMMON.TORSION'
7460       include 'COMMON.VAR'
7461       include 'COMMON.GEO'
7462       double precision pizda(2,2),ggg1(3),ggg2(3)
7463 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7464 cd        eello4=0.0d0
7465 cd        return
7466 cd      endif
7467 cd      print *,'eello4:',i,j,k,l,jj,kk
7468 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7469 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7470 cold      eij=facont_hb(jj,i)
7471 cold      ekl=facont_hb(kk,k)
7472 cold      ekont=eij*ekl
7473       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7474 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7475       gcorr_loc(k-1)=gcorr_loc(k-1)
7476      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7477       if (l.eq.j+1) then
7478         gcorr_loc(l-1)=gcorr_loc(l-1)
7479      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7480       else
7481         gcorr_loc(j-1)=gcorr_loc(j-1)
7482      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7483       endif
7484       do iii=1,2
7485         do kkk=1,5
7486           do lll=1,3
7487             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7488      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7489 cd            derx(lll,kkk,iii)=0.0d0
7490           enddo
7491         enddo
7492       enddo
7493 cd      gcorr_loc(l-1)=0.0d0
7494 cd      gcorr_loc(j-1)=0.0d0
7495 cd      gcorr_loc(k-1)=0.0d0
7496 cd      eel4=1.0d0
7497 cd      write (iout,*)'Contacts have occurred for peptide groups',
7498 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7499 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7500       if (j.lt.nres-1) then
7501         j1=j+1
7502         j2=j-1
7503       else
7504         j1=j-1
7505         j2=j-2
7506       endif
7507       if (l.lt.nres-1) then
7508         l1=l+1
7509         l2=l-1
7510       else
7511         l1=l-1
7512         l2=l-2
7513       endif
7514       do ll=1,3
7515 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7516 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7517         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7518         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7519 cgrad        ghalf=0.5d0*ggg1(ll)
7520         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7521         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7522         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7523         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7524         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7525         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7526 cgrad        ghalf=0.5d0*ggg2(ll)
7527         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7528         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7529         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7530         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7531         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7532         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7533       enddo
7534 cgrad      do m=i+1,j-1
7535 cgrad        do ll=1,3
7536 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7537 cgrad        enddo
7538 cgrad      enddo
7539 cgrad      do m=k+1,l-1
7540 cgrad        do ll=1,3
7541 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7542 cgrad        enddo
7543 cgrad      enddo
7544 cgrad      do m=i+2,j2
7545 cgrad        do ll=1,3
7546 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7547 cgrad        enddo
7548 cgrad      enddo
7549 cgrad      do m=k+2,l2
7550 cgrad        do ll=1,3
7551 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7552 cgrad        enddo
7553 cgrad      enddo
7554 cd      do iii=1,nres-3
7555 cd        write (2,*) iii,gcorr_loc(iii)
7556 cd      enddo
7557       eello4=ekont*eel4
7558 cd      write (2,*) 'ekont',ekont
7559 cd      write (iout,*) 'eello4',ekont*eel4
7560       return
7561       end
7562 C---------------------------------------------------------------------------
7563       double precision function eello5(i,j,k,l,jj,kk)
7564       implicit real*8 (a-h,o-z)
7565       include 'DIMENSIONS'
7566       include 'COMMON.IOUNITS'
7567       include 'COMMON.CHAIN'
7568       include 'COMMON.DERIV'
7569       include 'COMMON.INTERACT'
7570       include 'COMMON.CONTACTS'
7571       include 'COMMON.TORSION'
7572       include 'COMMON.VAR'
7573       include 'COMMON.GEO'
7574       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7575       double precision ggg1(3),ggg2(3)
7576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7577 C                                                                              C
7578 C                            Parallel chains                                   C
7579 C                                                                              C
7580 C          o             o                   o             o                   C
7581 C         /l\           / \             \   / \           / \   /              C
7582 C        /   \         /   \             \ /   \         /   \ /               C
7583 C       j| o |l1       | o |              o| o |         | o |o                C
7584 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7585 C      \i/   \         /   \ /             /   \         /   \                 C
7586 C       o    k1             o                                                  C
7587 C         (I)          (II)                (III)          (IV)                 C
7588 C                                                                              C
7589 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7590 C                                                                              C
7591 C                            Antiparallel chains                               C
7592 C                                                                              C
7593 C          o             o                   o             o                   C
7594 C         /j\           / \             \   / \           / \   /              C
7595 C        /   \         /   \             \ /   \         /   \ /               C
7596 C      j1| o |l        | o |              o| o |         | o |o                C
7597 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7598 C      \i/   \         /   \ /             /   \         /   \                 C
7599 C       o     k1            o                                                  C
7600 C         (I)          (II)                (III)          (IV)                 C
7601 C                                                                              C
7602 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7603 C                                                                              C
7604 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7605 C                                                                              C
7606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7607 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7608 cd        eello5=0.0d0
7609 cd        return
7610 cd      endif
7611 cd      write (iout,*)
7612 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7613 cd     &   ' and',k,l
7614       itk=itortyp(itype(k))
7615       itl=itortyp(itype(l))
7616       itj=itortyp(itype(j))
7617       eello5_1=0.0d0
7618       eello5_2=0.0d0
7619       eello5_3=0.0d0
7620       eello5_4=0.0d0
7621 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7622 cd     &   eel5_3_num,eel5_4_num)
7623       do iii=1,2
7624         do kkk=1,5
7625           do lll=1,3
7626             derx(lll,kkk,iii)=0.0d0
7627           enddo
7628         enddo
7629       enddo
7630 cd      eij=facont_hb(jj,i)
7631 cd      ekl=facont_hb(kk,k)
7632 cd      ekont=eij*ekl
7633 cd      write (iout,*)'Contacts have occurred for peptide groups',
7634 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7635 cd      goto 1111
7636 C Contribution from the graph I.
7637 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7638 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7639       call transpose2(EUg(1,1,k),auxmat(1,1))
7640       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7641       vv(1)=pizda(1,1)-pizda(2,2)
7642       vv(2)=pizda(1,2)+pizda(2,1)
7643       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7644      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7645 C Explicit gradient in virtual-dihedral angles.
7646       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7647      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7648      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7649       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7650       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7651       vv(1)=pizda(1,1)-pizda(2,2)
7652       vv(2)=pizda(1,2)+pizda(2,1)
7653       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7654      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7655      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7656       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7657       vv(1)=pizda(1,1)-pizda(2,2)
7658       vv(2)=pizda(1,2)+pizda(2,1)
7659       if (l.eq.j+1) then
7660         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7661      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7662      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7663       else
7664         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7665      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7666      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7667       endif
7668 C Cartesian gradient
7669       do iii=1,2
7670         do kkk=1,5
7671           do lll=1,3
7672             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7673      &        pizda(1,1))
7674             vv(1)=pizda(1,1)-pizda(2,2)
7675             vv(2)=pizda(1,2)+pizda(2,1)
7676             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7677      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7678      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7679           enddo
7680         enddo
7681       enddo
7682 c      goto 1112
7683 c1111  continue
7684 C Contribution from graph II
7685       call transpose2(EE(1,1,itk),auxmat(1,1))
7686       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7687       vv(1)=pizda(1,1)+pizda(2,2)
7688       vv(2)=pizda(2,1)-pizda(1,2)
7689       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7690      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7691 C Explicit gradient in virtual-dihedral angles.
7692       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7693      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7694       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7695       vv(1)=pizda(1,1)+pizda(2,2)
7696       vv(2)=pizda(2,1)-pizda(1,2)
7697       if (l.eq.j+1) then
7698         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7699      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7700      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7701       else
7702         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7703      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7704      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7705       endif
7706 C Cartesian gradient
7707       do iii=1,2
7708         do kkk=1,5
7709           do lll=1,3
7710             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7711      &        pizda(1,1))
7712             vv(1)=pizda(1,1)+pizda(2,2)
7713             vv(2)=pizda(2,1)-pizda(1,2)
7714             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7715      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7716      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7717           enddo
7718         enddo
7719       enddo
7720 cd      goto 1112
7721 cd1111  continue
7722       if (l.eq.j+1) then
7723 cd        goto 1110
7724 C Parallel orientation
7725 C Contribution from graph III
7726         call transpose2(EUg(1,1,l),auxmat(1,1))
7727         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7728         vv(1)=pizda(1,1)-pizda(2,2)
7729         vv(2)=pizda(1,2)+pizda(2,1)
7730         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7731      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7732 C Explicit gradient in virtual-dihedral angles.
7733         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7734      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7735      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7736         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7737         vv(1)=pizda(1,1)-pizda(2,2)
7738         vv(2)=pizda(1,2)+pizda(2,1)
7739         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7740      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7741      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7742         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7743         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7744         vv(1)=pizda(1,1)-pizda(2,2)
7745         vv(2)=pizda(1,2)+pizda(2,1)
7746         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7747      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7748      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7749 C Cartesian gradient
7750         do iii=1,2
7751           do kkk=1,5
7752             do lll=1,3
7753               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7754      &          pizda(1,1))
7755               vv(1)=pizda(1,1)-pizda(2,2)
7756               vv(2)=pizda(1,2)+pizda(2,1)
7757               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7758      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7759      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7760             enddo
7761           enddo
7762         enddo
7763 cd        goto 1112
7764 C Contribution from graph IV
7765 cd1110    continue
7766         call transpose2(EE(1,1,itl),auxmat(1,1))
7767         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7768         vv(1)=pizda(1,1)+pizda(2,2)
7769         vv(2)=pizda(2,1)-pizda(1,2)
7770         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7771      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7772 C Explicit gradient in virtual-dihedral angles.
7773         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7774      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7775         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7776         vv(1)=pizda(1,1)+pizda(2,2)
7777         vv(2)=pizda(2,1)-pizda(1,2)
7778         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7779      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7780      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7781 C Cartesian gradient
7782         do iii=1,2
7783           do kkk=1,5
7784             do lll=1,3
7785               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7786      &          pizda(1,1))
7787               vv(1)=pizda(1,1)+pizda(2,2)
7788               vv(2)=pizda(2,1)-pizda(1,2)
7789               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7790      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7791      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7792             enddo
7793           enddo
7794         enddo
7795       else
7796 C Antiparallel orientation
7797 C Contribution from graph III
7798 c        goto 1110
7799         call transpose2(EUg(1,1,j),auxmat(1,1))
7800         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7801         vv(1)=pizda(1,1)-pizda(2,2)
7802         vv(2)=pizda(1,2)+pizda(2,1)
7803         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7804      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7805 C Explicit gradient in virtual-dihedral angles.
7806         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7807      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7808      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7809         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7810         vv(1)=pizda(1,1)-pizda(2,2)
7811         vv(2)=pizda(1,2)+pizda(2,1)
7812         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7813      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7814      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7815         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7816         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7817         vv(1)=pizda(1,1)-pizda(2,2)
7818         vv(2)=pizda(1,2)+pizda(2,1)
7819         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7820      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7821      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7822 C Cartesian gradient
7823         do iii=1,2
7824           do kkk=1,5
7825             do lll=1,3
7826               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7827      &          pizda(1,1))
7828               vv(1)=pizda(1,1)-pizda(2,2)
7829               vv(2)=pizda(1,2)+pizda(2,1)
7830               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7831      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7832      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7833             enddo
7834           enddo
7835         enddo
7836 cd        goto 1112
7837 C Contribution from graph IV
7838 1110    continue
7839         call transpose2(EE(1,1,itj),auxmat(1,1))
7840         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7841         vv(1)=pizda(1,1)+pizda(2,2)
7842         vv(2)=pizda(2,1)-pizda(1,2)
7843         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7844      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7845 C Explicit gradient in virtual-dihedral angles.
7846         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7847      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7848         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7849         vv(1)=pizda(1,1)+pizda(2,2)
7850         vv(2)=pizda(2,1)-pizda(1,2)
7851         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7852      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7853      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7854 C Cartesian gradient
7855         do iii=1,2
7856           do kkk=1,5
7857             do lll=1,3
7858               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7859      &          pizda(1,1))
7860               vv(1)=pizda(1,1)+pizda(2,2)
7861               vv(2)=pizda(2,1)-pizda(1,2)
7862               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7863      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7864      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7865             enddo
7866           enddo
7867         enddo
7868       endif
7869 1112  continue
7870       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7871 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7872 cd        write (2,*) 'ijkl',i,j,k,l
7873 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7874 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7875 cd      endif
7876 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7877 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7878 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7879 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7880       if (j.lt.nres-1) then
7881         j1=j+1
7882         j2=j-1
7883       else
7884         j1=j-1
7885         j2=j-2
7886       endif
7887       if (l.lt.nres-1) then
7888         l1=l+1
7889         l2=l-1
7890       else
7891         l1=l-1
7892         l2=l-2
7893       endif
7894 cd      eij=1.0d0
7895 cd      ekl=1.0d0
7896 cd      ekont=1.0d0
7897 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7898 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7899 C        summed up outside the subrouine as for the other subroutines
7900 C        handling long-range interactions. The old code is commented out
7901 C        with "cgrad" to keep track of changes.
7902       do ll=1,3
7903 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7904 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7905         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7906         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7907 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7908 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7909 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7910 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7911 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7912 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7913 c     &   gradcorr5ij,
7914 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7915 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7916 cgrad        ghalf=0.5d0*ggg1(ll)
7917 cd        ghalf=0.0d0
7918         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7919         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7920         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7921         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7922         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7923         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7924 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7925 cgrad        ghalf=0.5d0*ggg2(ll)
7926 cd        ghalf=0.0d0
7927         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7928         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7929         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7930         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7931         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7932         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7933       enddo
7934 cd      goto 1112
7935 cgrad      do m=i+1,j-1
7936 cgrad        do ll=1,3
7937 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7938 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7939 cgrad        enddo
7940 cgrad      enddo
7941 cgrad      do m=k+1,l-1
7942 cgrad        do ll=1,3
7943 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7944 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7945 cgrad        enddo
7946 cgrad      enddo
7947 c1112  continue
7948 cgrad      do m=i+2,j2
7949 cgrad        do ll=1,3
7950 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7951 cgrad        enddo
7952 cgrad      enddo
7953 cgrad      do m=k+2,l2
7954 cgrad        do ll=1,3
7955 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7956 cgrad        enddo
7957 cgrad      enddo
7958 cd      do iii=1,nres-3
7959 cd        write (2,*) iii,g_corr5_loc(iii)
7960 cd      enddo
7961       eello5=ekont*eel5
7962 cd      write (2,*) 'ekont',ekont
7963 cd      write (iout,*) 'eello5',ekont*eel5
7964       return
7965       end
7966 c--------------------------------------------------------------------------
7967       double precision function eello6(i,j,k,l,jj,kk)
7968       implicit real*8 (a-h,o-z)
7969       include 'DIMENSIONS'
7970       include 'COMMON.IOUNITS'
7971       include 'COMMON.CHAIN'
7972       include 'COMMON.DERIV'
7973       include 'COMMON.INTERACT'
7974       include 'COMMON.CONTACTS'
7975       include 'COMMON.TORSION'
7976       include 'COMMON.VAR'
7977       include 'COMMON.GEO'
7978       include 'COMMON.FFIELD'
7979       double precision ggg1(3),ggg2(3)
7980 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7981 cd        eello6=0.0d0
7982 cd        return
7983 cd      endif
7984 cd      write (iout,*)
7985 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7986 cd     &   ' and',k,l
7987       eello6_1=0.0d0
7988       eello6_2=0.0d0
7989       eello6_3=0.0d0
7990       eello6_4=0.0d0
7991       eello6_5=0.0d0
7992       eello6_6=0.0d0
7993 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7994 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7995       do iii=1,2
7996         do kkk=1,5
7997           do lll=1,3
7998             derx(lll,kkk,iii)=0.0d0
7999           enddo
8000         enddo
8001       enddo
8002 cd      eij=facont_hb(jj,i)
8003 cd      ekl=facont_hb(kk,k)
8004 cd      ekont=eij*ekl
8005 cd      eij=1.0d0
8006 cd      ekl=1.0d0
8007 cd      ekont=1.0d0
8008       if (l.eq.j+1) then
8009         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8010         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8011         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8012         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8013         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8014         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8015       else
8016         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8017         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8018         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8019         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8020         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8021           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8022         else
8023           eello6_5=0.0d0
8024         endif
8025         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8026       endif
8027 C If turn contributions are considered, they will be handled separately.
8028       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8029 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8030 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8031 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8032 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8033 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8034 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8035 cd      goto 1112
8036       if (j.lt.nres-1) then
8037         j1=j+1
8038         j2=j-1
8039       else
8040         j1=j-1
8041         j2=j-2
8042       endif
8043       if (l.lt.nres-1) then
8044         l1=l+1
8045         l2=l-1
8046       else
8047         l1=l-1
8048         l2=l-2
8049       endif
8050       do ll=1,3
8051 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8052 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8053 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8054 cgrad        ghalf=0.5d0*ggg1(ll)
8055 cd        ghalf=0.0d0
8056         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8057         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8058         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8059         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8060         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8061         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8062         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8063         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8064 cgrad        ghalf=0.5d0*ggg2(ll)
8065 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8066 cd        ghalf=0.0d0
8067         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8068         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8069         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8070         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8071         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8072         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8073       enddo
8074 cd      goto 1112
8075 cgrad      do m=i+1,j-1
8076 cgrad        do ll=1,3
8077 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8078 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8079 cgrad        enddo
8080 cgrad      enddo
8081 cgrad      do m=k+1,l-1
8082 cgrad        do ll=1,3
8083 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8084 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8085 cgrad        enddo
8086 cgrad      enddo
8087 cgrad1112  continue
8088 cgrad      do m=i+2,j2
8089 cgrad        do ll=1,3
8090 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8091 cgrad        enddo
8092 cgrad      enddo
8093 cgrad      do m=k+2,l2
8094 cgrad        do ll=1,3
8095 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8096 cgrad        enddo
8097 cgrad      enddo
8098 cd      do iii=1,nres-3
8099 cd        write (2,*) iii,g_corr6_loc(iii)
8100 cd      enddo
8101       eello6=ekont*eel6
8102 cd      write (2,*) 'ekont',ekont
8103 cd      write (iout,*) 'eello6',ekont*eel6
8104       return
8105       end
8106 c--------------------------------------------------------------------------
8107       double precision function eello6_graph1(i,j,k,l,imat,swap)
8108       implicit real*8 (a-h,o-z)
8109       include 'DIMENSIONS'
8110       include 'COMMON.IOUNITS'
8111       include 'COMMON.CHAIN'
8112       include 'COMMON.DERIV'
8113       include 'COMMON.INTERACT'
8114       include 'COMMON.CONTACTS'
8115       include 'COMMON.TORSION'
8116       include 'COMMON.VAR'
8117       include 'COMMON.GEO'
8118       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8119       logical swap
8120       logical lprn
8121       common /kutas/ lprn
8122 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8123 C                                                                              C
8124 C      Parallel       Antiparallel                                             C
8125 C                                                                              C
8126 C          o             o                                                     C
8127 C         /l\           /j\                                                    C
8128 C        /   \         /   \                                                   C
8129 C       /| o |         | o |\                                                  C
8130 C     \ j|/k\|  /   \  |/k\|l /                                                C
8131 C      \ /   \ /     \ /   \ /                                                 C
8132 C       o     o       o     o                                                  C
8133 C       i             i                                                        C
8134 C                                                                              C
8135 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8136       itk=itortyp(itype(k))
8137       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8138       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8139       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8140       call transpose2(EUgC(1,1,k),auxmat(1,1))
8141       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8142       vv1(1)=pizda1(1,1)-pizda1(2,2)
8143       vv1(2)=pizda1(1,2)+pizda1(2,1)
8144       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8145       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8146       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8147       s5=scalar2(vv(1),Dtobr2(1,i))
8148 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8149       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8150       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8151      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8152      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8153      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8154      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8155      & +scalar2(vv(1),Dtobr2der(1,i)))
8156       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8157       vv1(1)=pizda1(1,1)-pizda1(2,2)
8158       vv1(2)=pizda1(1,2)+pizda1(2,1)
8159       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8160       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8161       if (l.eq.j+1) then
8162         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8163      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8164      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8165      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8166      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8167       else
8168         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8169      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8170      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8171      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8172      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8173       endif
8174       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8175       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8176       vv1(1)=pizda1(1,1)-pizda1(2,2)
8177       vv1(2)=pizda1(1,2)+pizda1(2,1)
8178       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8179      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8180      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8181      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8182       do iii=1,2
8183         if (swap) then
8184           ind=3-iii
8185         else
8186           ind=iii
8187         endif
8188         do kkk=1,5
8189           do lll=1,3
8190             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8191             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8192             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8193             call transpose2(EUgC(1,1,k),auxmat(1,1))
8194             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8195      &        pizda1(1,1))
8196             vv1(1)=pizda1(1,1)-pizda1(2,2)
8197             vv1(2)=pizda1(1,2)+pizda1(2,1)
8198             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8199             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8200      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8201             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8202      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8203             s5=scalar2(vv(1),Dtobr2(1,i))
8204             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8205           enddo
8206         enddo
8207       enddo
8208       return
8209       end
8210 c----------------------------------------------------------------------------
8211       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8212       implicit real*8 (a-h,o-z)
8213       include 'DIMENSIONS'
8214       include 'COMMON.IOUNITS'
8215       include 'COMMON.CHAIN'
8216       include 'COMMON.DERIV'
8217       include 'COMMON.INTERACT'
8218       include 'COMMON.CONTACTS'
8219       include 'COMMON.TORSION'
8220       include 'COMMON.VAR'
8221       include 'COMMON.GEO'
8222       logical swap
8223       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8224      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8225       logical lprn
8226       common /kutas/ lprn
8227 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8228 C                                                                              C
8229 C      Parallel       Antiparallel                                             C
8230 C                                                                              C
8231 C          o             o                                                     C
8232 C     \   /l\           /j\   /                                                C
8233 C      \ /   \         /   \ /                                                 C
8234 C       o| o |         | o |o                                                  C
8235 C     \ j|/k\|      \  |/k\|l                                                  C
8236 C      \ /   \       \ /   \                                                   C
8237 C       o             o                                                        C
8238 C       i             i                                                        C
8239 C                                                                              C
8240 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8241 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8242 C AL 7/4/01 s1 would occur in the sixth-order moment,
8243 C           but not in a cluster cumulant
8244 #ifdef MOMENT
8245       s1=dip(1,jj,i)*dip(1,kk,k)
8246 #endif
8247       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8248       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8249       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8250       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8251       call transpose2(EUg(1,1,k),auxmat(1,1))
8252       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8253       vv(1)=pizda(1,1)-pizda(2,2)
8254       vv(2)=pizda(1,2)+pizda(2,1)
8255       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8256 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8257 #ifdef MOMENT
8258       eello6_graph2=-(s1+s2+s3+s4)
8259 #else
8260       eello6_graph2=-(s2+s3+s4)
8261 #endif
8262 c      eello6_graph2=-s3
8263 C Derivatives in gamma(i-1)
8264       if (i.gt.1) then
8265 #ifdef MOMENT
8266         s1=dipderg(1,jj,i)*dip(1,kk,k)
8267 #endif
8268         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8269         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8270         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8271         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8272 #ifdef MOMENT
8273         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8274 #else
8275         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8276 #endif
8277 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8278       endif
8279 C Derivatives in gamma(k-1)
8280 #ifdef MOMENT
8281       s1=dip(1,jj,i)*dipderg(1,kk,k)
8282 #endif
8283       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8284       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8285       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8286       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8287       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8288       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8289       vv(1)=pizda(1,1)-pizda(2,2)
8290       vv(2)=pizda(1,2)+pizda(2,1)
8291       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8292 #ifdef MOMENT
8293       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8294 #else
8295       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8296 #endif
8297 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8298 C Derivatives in gamma(j-1) or gamma(l-1)
8299       if (j.gt.1) then
8300 #ifdef MOMENT
8301         s1=dipderg(3,jj,i)*dip(1,kk,k)
8302 #endif
8303         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8304         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8305         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8306         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8307         vv(1)=pizda(1,1)-pizda(2,2)
8308         vv(2)=pizda(1,2)+pizda(2,1)
8309         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8310 #ifdef MOMENT
8311         if (swap) then
8312           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8313         else
8314           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8315         endif
8316 #endif
8317         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8318 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8319       endif
8320 C Derivatives in gamma(l-1) or gamma(j-1)
8321       if (l.gt.1) then
8322 #ifdef MOMENT
8323         s1=dip(1,jj,i)*dipderg(3,kk,k)
8324 #endif
8325         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8326         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8327         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8328         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8329         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8330         vv(1)=pizda(1,1)-pizda(2,2)
8331         vv(2)=pizda(1,2)+pizda(2,1)
8332         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8333 #ifdef MOMENT
8334         if (swap) then
8335           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8336         else
8337           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8338         endif
8339 #endif
8340         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8341 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8342       endif
8343 C Cartesian derivatives.
8344       if (lprn) then
8345         write (2,*) 'In eello6_graph2'
8346         do iii=1,2
8347           write (2,*) 'iii=',iii
8348           do kkk=1,5
8349             write (2,*) 'kkk=',kkk
8350             do jjj=1,2
8351               write (2,'(3(2f10.5),5x)')
8352      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8353             enddo
8354           enddo
8355         enddo
8356       endif
8357       do iii=1,2
8358         do kkk=1,5
8359           do lll=1,3
8360 #ifdef MOMENT
8361             if (iii.eq.1) then
8362               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8363             else
8364               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8365             endif
8366 #endif
8367             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8368      &        auxvec(1))
8369             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8370             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8371      &        auxvec(1))
8372             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8373             call transpose2(EUg(1,1,k),auxmat(1,1))
8374             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8375      &        pizda(1,1))
8376             vv(1)=pizda(1,1)-pizda(2,2)
8377             vv(2)=pizda(1,2)+pizda(2,1)
8378             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8379 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8380 #ifdef MOMENT
8381             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8382 #else
8383             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8384 #endif
8385             if (swap) then
8386               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8387             else
8388               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8389             endif
8390           enddo
8391         enddo
8392       enddo
8393       return
8394       end
8395 c----------------------------------------------------------------------------
8396       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8397       implicit real*8 (a-h,o-z)
8398       include 'DIMENSIONS'
8399       include 'COMMON.IOUNITS'
8400       include 'COMMON.CHAIN'
8401       include 'COMMON.DERIV'
8402       include 'COMMON.INTERACT'
8403       include 'COMMON.CONTACTS'
8404       include 'COMMON.TORSION'
8405       include 'COMMON.VAR'
8406       include 'COMMON.GEO'
8407       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8408       logical swap
8409 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8410 C                                                                              C
8411 C      Parallel       Antiparallel                                             C
8412 C                                                                              C
8413 C          o             o                                                     C
8414 C         /l\   /   \   /j\                                                    C
8415 C        /   \ /     \ /   \                                                   C
8416 C       /| o |o       o| o |\                                                  C
8417 C       j|/k\|  /      |/k\|l /                                                C
8418 C        /   \ /       /   \ /                                                 C
8419 C       /     o       /     o                                                  C
8420 C       i             i                                                        C
8421 C                                                                              C
8422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8423 C
8424 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8425 C           energy moment and not to the cluster cumulant.
8426       iti=itortyp(itype(i))
8427       if (j.lt.nres-1) then
8428         itj1=itortyp(itype(j+1))
8429       else
8430         itj1=ntortyp+1
8431       endif
8432       itk=itortyp(itype(k))
8433       itk1=itortyp(itype(k+1))
8434       if (l.lt.nres-1) then
8435         itl1=itortyp(itype(l+1))
8436       else
8437         itl1=ntortyp+1
8438       endif
8439 #ifdef MOMENT
8440       s1=dip(4,jj,i)*dip(4,kk,k)
8441 #endif
8442       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8443       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8444       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8445       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8446       call transpose2(EE(1,1,itk),auxmat(1,1))
8447       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8448       vv(1)=pizda(1,1)+pizda(2,2)
8449       vv(2)=pizda(2,1)-pizda(1,2)
8450       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8451 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8452 cd     & "sum",-(s2+s3+s4)
8453 #ifdef MOMENT
8454       eello6_graph3=-(s1+s2+s3+s4)
8455 #else
8456       eello6_graph3=-(s2+s3+s4)
8457 #endif
8458 c      eello6_graph3=-s4
8459 C Derivatives in gamma(k-1)
8460       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8461       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8462       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8463       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8464 C Derivatives in gamma(l-1)
8465       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8466       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8467       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8468       vv(1)=pizda(1,1)+pizda(2,2)
8469       vv(2)=pizda(2,1)-pizda(1,2)
8470       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8471       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8472 C Cartesian derivatives.
8473       do iii=1,2
8474         do kkk=1,5
8475           do lll=1,3
8476 #ifdef MOMENT
8477             if (iii.eq.1) then
8478               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8479             else
8480               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8481             endif
8482 #endif
8483             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8484      &        auxvec(1))
8485             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8486             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8487      &        auxvec(1))
8488             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8489             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8490      &        pizda(1,1))
8491             vv(1)=pizda(1,1)+pizda(2,2)
8492             vv(2)=pizda(2,1)-pizda(1,2)
8493             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8494 #ifdef MOMENT
8495             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8496 #else
8497             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8498 #endif
8499             if (swap) then
8500               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8501             else
8502               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8503             endif
8504 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8505           enddo
8506         enddo
8507       enddo
8508       return
8509       end
8510 c----------------------------------------------------------------------------
8511       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8512       implicit real*8 (a-h,o-z)
8513       include 'DIMENSIONS'
8514       include 'COMMON.IOUNITS'
8515       include 'COMMON.CHAIN'
8516       include 'COMMON.DERIV'
8517       include 'COMMON.INTERACT'
8518       include 'COMMON.CONTACTS'
8519       include 'COMMON.TORSION'
8520       include 'COMMON.VAR'
8521       include 'COMMON.GEO'
8522       include 'COMMON.FFIELD'
8523       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8524      & auxvec1(2),auxmat1(2,2)
8525       logical swap
8526 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8527 C                                                                              C
8528 C      Parallel       Antiparallel                                             C
8529 C                                                                              C
8530 C          o             o                                                     C
8531 C         /l\   /   \   /j\                                                    C
8532 C        /   \ /     \ /   \                                                   C
8533 C       /| o |o       o| o |\                                                  C
8534 C     \ j|/k\|      \  |/k\|l                                                  C
8535 C      \ /   \       \ /   \                                                   C
8536 C       o     \       o     \                                                  C
8537 C       i             i                                                        C
8538 C                                                                              C
8539 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8540 C
8541 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8542 C           energy moment and not to the cluster cumulant.
8543 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8544       iti=itortyp(itype(i))
8545       itj=itortyp(itype(j))
8546       if (j.lt.nres-1) then
8547         itj1=itortyp(itype(j+1))
8548       else
8549         itj1=ntortyp+1
8550       endif
8551       itk=itortyp(itype(k))
8552       if (k.lt.nres-1) then
8553         itk1=itortyp(itype(k+1))
8554       else
8555         itk1=ntortyp+1
8556       endif
8557       itl=itortyp(itype(l))
8558       if (l.lt.nres-1) then
8559         itl1=itortyp(itype(l+1))
8560       else
8561         itl1=ntortyp+1
8562       endif
8563 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8564 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8565 cd     & ' itl',itl,' itl1',itl1
8566 #ifdef MOMENT
8567       if (imat.eq.1) then
8568         s1=dip(3,jj,i)*dip(3,kk,k)
8569       else
8570         s1=dip(2,jj,j)*dip(2,kk,l)
8571       endif
8572 #endif
8573       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8574       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8575       if (j.eq.l+1) then
8576         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8577         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8578       else
8579         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8580         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8581       endif
8582       call transpose2(EUg(1,1,k),auxmat(1,1))
8583       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8584       vv(1)=pizda(1,1)-pizda(2,2)
8585       vv(2)=pizda(2,1)+pizda(1,2)
8586       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8587 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8588 #ifdef MOMENT
8589       eello6_graph4=-(s1+s2+s3+s4)
8590 #else
8591       eello6_graph4=-(s2+s3+s4)
8592 #endif
8593 C Derivatives in gamma(i-1)
8594       if (i.gt.1) then
8595 #ifdef MOMENT
8596         if (imat.eq.1) then
8597           s1=dipderg(2,jj,i)*dip(3,kk,k)
8598         else
8599           s1=dipderg(4,jj,j)*dip(2,kk,l)
8600         endif
8601 #endif
8602         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8603         if (j.eq.l+1) then
8604           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8605           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8606         else
8607           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8608           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8609         endif
8610         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8611         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8612 cd          write (2,*) 'turn6 derivatives'
8613 #ifdef MOMENT
8614           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8615 #else
8616           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8617 #endif
8618         else
8619 #ifdef MOMENT
8620           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8621 #else
8622           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8623 #endif
8624         endif
8625       endif
8626 C Derivatives in gamma(k-1)
8627 #ifdef MOMENT
8628       if (imat.eq.1) then
8629         s1=dip(3,jj,i)*dipderg(2,kk,k)
8630       else
8631         s1=dip(2,jj,j)*dipderg(4,kk,l)
8632       endif
8633 #endif
8634       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8635       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8636       if (j.eq.l+1) then
8637         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8638         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8639       else
8640         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8641         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8642       endif
8643       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8644       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8645       vv(1)=pizda(1,1)-pizda(2,2)
8646       vv(2)=pizda(2,1)+pizda(1,2)
8647       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8648       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8649 #ifdef MOMENT
8650         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8651 #else
8652         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8653 #endif
8654       else
8655 #ifdef MOMENT
8656         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8657 #else
8658         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8659 #endif
8660       endif
8661 C Derivatives in gamma(j-1) or gamma(l-1)
8662       if (l.eq.j+1 .and. l.gt.1) then
8663         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8664         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8665         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8666         vv(1)=pizda(1,1)-pizda(2,2)
8667         vv(2)=pizda(2,1)+pizda(1,2)
8668         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8669         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8670       else if (j.gt.1) then
8671         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8672         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8673         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8674         vv(1)=pizda(1,1)-pizda(2,2)
8675         vv(2)=pizda(2,1)+pizda(1,2)
8676         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8677         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8678           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8679         else
8680           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8681         endif
8682       endif
8683 C Cartesian derivatives.
8684       do iii=1,2
8685         do kkk=1,5
8686           do lll=1,3
8687 #ifdef MOMENT
8688             if (iii.eq.1) then
8689               if (imat.eq.1) then
8690                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8691               else
8692                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8693               endif
8694             else
8695               if (imat.eq.1) then
8696                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8697               else
8698                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8699               endif
8700             endif
8701 #endif
8702             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8703      &        auxvec(1))
8704             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8705             if (j.eq.l+1) then
8706               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8707      &          b1(1,j+1),auxvec(1))
8708               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8709             else
8710               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8711      &          b1(1,l+1),auxvec(1))
8712               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8713             endif
8714             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8715      &        pizda(1,1))
8716             vv(1)=pizda(1,1)-pizda(2,2)
8717             vv(2)=pizda(2,1)+pizda(1,2)
8718             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8719             if (swap) then
8720               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8721 #ifdef MOMENT
8722                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8723      &             -(s1+s2+s4)
8724 #else
8725                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8726      &             -(s2+s4)
8727 #endif
8728                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8729               else
8730 #ifdef MOMENT
8731                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8732 #else
8733                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8734 #endif
8735                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8736               endif
8737             else
8738 #ifdef MOMENT
8739               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8740 #else
8741               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8742 #endif
8743               if (l.eq.j+1) then
8744                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8745               else
8746                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8747               endif
8748             endif
8749           enddo
8750         enddo
8751       enddo
8752       return
8753       end
8754 c----------------------------------------------------------------------------
8755       double precision function eello_turn6(i,jj,kk)
8756       implicit real*8 (a-h,o-z)
8757       include 'DIMENSIONS'
8758       include 'COMMON.IOUNITS'
8759       include 'COMMON.CHAIN'
8760       include 'COMMON.DERIV'
8761       include 'COMMON.INTERACT'
8762       include 'COMMON.CONTACTS'
8763       include 'COMMON.TORSION'
8764       include 'COMMON.VAR'
8765       include 'COMMON.GEO'
8766       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8767      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8768      &  ggg1(3),ggg2(3)
8769       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8770      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8771 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8772 C           the respective energy moment and not to the cluster cumulant.
8773       s1=0.0d0
8774       s8=0.0d0
8775       s13=0.0d0
8776 c
8777       eello_turn6=0.0d0
8778       j=i+4
8779       k=i+1
8780       l=i+3
8781       iti=itortyp(itype(i))
8782       itk=itortyp(itype(k))
8783       itk1=itortyp(itype(k+1))
8784       itl=itortyp(itype(l))
8785       itj=itortyp(itype(j))
8786 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8787 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8788 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8789 cd        eello6=0.0d0
8790 cd        return
8791 cd      endif
8792 cd      write (iout,*)
8793 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8794 cd     &   ' and',k,l
8795 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8796       do iii=1,2
8797         do kkk=1,5
8798           do lll=1,3
8799             derx_turn(lll,kkk,iii)=0.0d0
8800           enddo
8801         enddo
8802       enddo
8803 cd      eij=1.0d0
8804 cd      ekl=1.0d0
8805 cd      ekont=1.0d0
8806       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8807 cd      eello6_5=0.0d0
8808 cd      write (2,*) 'eello6_5',eello6_5
8809 #ifdef MOMENT
8810       call transpose2(AEA(1,1,1),auxmat(1,1))
8811       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8812       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8813       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8814 #endif
8815       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8816       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8817       s2 = scalar2(b1(1,k),vtemp1(1))
8818 #ifdef MOMENT
8819       call transpose2(AEA(1,1,2),atemp(1,1))
8820       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8821       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8822       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8823 #endif
8824       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8825       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8826       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8827 #ifdef MOMENT
8828       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8829       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8830       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8831       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8832       ss13 = scalar2(b1(1,k),vtemp4(1))
8833       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8834 #endif
8835 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8836 c      s1=0.0d0
8837 c      s2=0.0d0
8838 c      s8=0.0d0
8839 c      s12=0.0d0
8840 c      s13=0.0d0
8841       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8842 C Derivatives in gamma(i+2)
8843       s1d =0.0d0
8844       s8d =0.0d0
8845 #ifdef MOMENT
8846       call transpose2(AEA(1,1,1),auxmatd(1,1))
8847       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8848       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8849       call transpose2(AEAderg(1,1,2),atempd(1,1))
8850       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8851       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8852 #endif
8853       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8854       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8855       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8856 c      s1d=0.0d0
8857 c      s2d=0.0d0
8858 c      s8d=0.0d0
8859 c      s12d=0.0d0
8860 c      s13d=0.0d0
8861       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8862 C Derivatives in gamma(i+3)
8863 #ifdef MOMENT
8864       call transpose2(AEA(1,1,1),auxmatd(1,1))
8865       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8866       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8867       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8868 #endif
8869       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8870       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8871       s2d = scalar2(b1(1,k),vtemp1d(1))
8872 #ifdef MOMENT
8873       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8874       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8875 #endif
8876       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8877 #ifdef MOMENT
8878       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8879       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8880       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8881 #endif
8882 c      s1d=0.0d0
8883 c      s2d=0.0d0
8884 c      s8d=0.0d0
8885 c      s12d=0.0d0
8886 c      s13d=0.0d0
8887 #ifdef MOMENT
8888       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8889      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8890 #else
8891       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8892      &               -0.5d0*ekont*(s2d+s12d)
8893 #endif
8894 C Derivatives in gamma(i+4)
8895       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8896       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8897       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8898 #ifdef MOMENT
8899       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8900       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8901       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8902 #endif
8903 c      s1d=0.0d0
8904 c      s2d=0.0d0
8905 c      s8d=0.0d0
8906 C      s12d=0.0d0
8907 c      s13d=0.0d0
8908 #ifdef MOMENT
8909       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8910 #else
8911       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8912 #endif
8913 C Derivatives in gamma(i+5)
8914 #ifdef MOMENT
8915       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8916       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8917       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8918 #endif
8919       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8920       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8921       s2d = scalar2(b1(1,k),vtemp1d(1))
8922 #ifdef MOMENT
8923       call transpose2(AEA(1,1,2),atempd(1,1))
8924       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8925       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8926 #endif
8927       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8928       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8929 #ifdef MOMENT
8930       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8931       ss13d = scalar2(b1(1,k),vtemp4d(1))
8932       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8933 #endif
8934 c      s1d=0.0d0
8935 c      s2d=0.0d0
8936 c      s8d=0.0d0
8937 c      s12d=0.0d0
8938 c      s13d=0.0d0
8939 #ifdef MOMENT
8940       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8941      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8942 #else
8943       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8944      &               -0.5d0*ekont*(s2d+s12d)
8945 #endif
8946 C Cartesian derivatives
8947       do iii=1,2
8948         do kkk=1,5
8949           do lll=1,3
8950 #ifdef MOMENT
8951             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8952             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8953             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8954 #endif
8955             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8956             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8957      &          vtemp1d(1))
8958             s2d = scalar2(b1(1,k),vtemp1d(1))
8959 #ifdef MOMENT
8960             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8961             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8962             s8d = -(atempd(1,1)+atempd(2,2))*
8963      &           scalar2(cc(1,1,itl),vtemp2(1))
8964 #endif
8965             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8966      &           auxmatd(1,1))
8967             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8968             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8969 c      s1d=0.0d0
8970 c      s2d=0.0d0
8971 c      s8d=0.0d0
8972 c      s12d=0.0d0
8973 c      s13d=0.0d0
8974 #ifdef MOMENT
8975             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8976      &        - 0.5d0*(s1d+s2d)
8977 #else
8978             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8979      &        - 0.5d0*s2d
8980 #endif
8981 #ifdef MOMENT
8982             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8983      &        - 0.5d0*(s8d+s12d)
8984 #else
8985             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8986      &        - 0.5d0*s12d
8987 #endif
8988           enddo
8989         enddo
8990       enddo
8991 #ifdef MOMENT
8992       do kkk=1,5
8993         do lll=1,3
8994           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8995      &      achuj_tempd(1,1))
8996           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8997           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8998           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8999           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9000           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9001      &      vtemp4d(1))
9002           ss13d = scalar2(b1(1,k),vtemp4d(1))
9003           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9004           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9005         enddo
9006       enddo
9007 #endif
9008 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9009 cd     &  16*eel_turn6_num
9010 cd      goto 1112
9011       if (j.lt.nres-1) then
9012         j1=j+1
9013         j2=j-1
9014       else
9015         j1=j-1
9016         j2=j-2
9017       endif
9018       if (l.lt.nres-1) then
9019         l1=l+1
9020         l2=l-1
9021       else
9022         l1=l-1
9023         l2=l-2
9024       endif
9025       do ll=1,3
9026 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9027 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9028 cgrad        ghalf=0.5d0*ggg1(ll)
9029 cd        ghalf=0.0d0
9030         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9031         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9032         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9033      &    +ekont*derx_turn(ll,2,1)
9034         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9035         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9036      &    +ekont*derx_turn(ll,4,1)
9037         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9038         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9039         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9040 cgrad        ghalf=0.5d0*ggg2(ll)
9041 cd        ghalf=0.0d0
9042         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9043      &    +ekont*derx_turn(ll,2,2)
9044         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9045         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9046      &    +ekont*derx_turn(ll,4,2)
9047         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9048         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9049         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9050       enddo
9051 cd      goto 1112
9052 cgrad      do m=i+1,j-1
9053 cgrad        do ll=1,3
9054 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9055 cgrad        enddo
9056 cgrad      enddo
9057 cgrad      do m=k+1,l-1
9058 cgrad        do ll=1,3
9059 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9060 cgrad        enddo
9061 cgrad      enddo
9062 cgrad1112  continue
9063 cgrad      do m=i+2,j2
9064 cgrad        do ll=1,3
9065 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9066 cgrad        enddo
9067 cgrad      enddo
9068 cgrad      do m=k+2,l2
9069 cgrad        do ll=1,3
9070 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9071 cgrad        enddo
9072 cgrad      enddo
9073 cd      do iii=1,nres-3
9074 cd        write (2,*) iii,g_corr6_loc(iii)
9075 cd      enddo
9076       eello_turn6=ekont*eel_turn6
9077 cd      write (2,*) 'ekont',ekont
9078 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9079       return
9080       end
9081
9082 C-----------------------------------------------------------------------------
9083       double precision function scalar(u,v)
9084 !DIR$ INLINEALWAYS scalar
9085 #ifndef OSF
9086 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9087 #endif
9088       implicit none
9089       double precision u(3),v(3)
9090 cd      double precision sc
9091 cd      integer i
9092 cd      sc=0.0d0
9093 cd      do i=1,3
9094 cd        sc=sc+u(i)*v(i)
9095 cd      enddo
9096 cd      scalar=sc
9097
9098       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9099       return
9100       end
9101 crc-------------------------------------------------
9102       SUBROUTINE MATVEC2(A1,V1,V2)
9103 !DIR$ INLINEALWAYS MATVEC2
9104 #ifndef OSF
9105 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9106 #endif
9107       implicit real*8 (a-h,o-z)
9108       include 'DIMENSIONS'
9109       DIMENSION A1(2,2),V1(2),V2(2)
9110 c      DO 1 I=1,2
9111 c        VI=0.0
9112 c        DO 3 K=1,2
9113 c    3     VI=VI+A1(I,K)*V1(K)
9114 c        Vaux(I)=VI
9115 c    1 CONTINUE
9116
9117       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9118       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9119
9120       v2(1)=vaux1
9121       v2(2)=vaux2
9122       END
9123 C---------------------------------------
9124       SUBROUTINE MATMAT2(A1,A2,A3)
9125 #ifndef OSF
9126 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9127 #endif
9128       implicit real*8 (a-h,o-z)
9129       include 'DIMENSIONS'
9130       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9131 c      DIMENSION AI3(2,2)
9132 c        DO  J=1,2
9133 c          A3IJ=0.0
9134 c          DO K=1,2
9135 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9136 c          enddo
9137 c          A3(I,J)=A3IJ
9138 c       enddo
9139 c      enddo
9140
9141       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9142       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9143       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9144       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9145
9146       A3(1,1)=AI3_11
9147       A3(2,1)=AI3_21
9148       A3(1,2)=AI3_12
9149       A3(2,2)=AI3_22
9150       END
9151
9152 c-------------------------------------------------------------------------
9153       double precision function scalar2(u,v)
9154 !DIR$ INLINEALWAYS scalar2
9155       implicit none
9156       double precision u(2),v(2)
9157       double precision sc
9158       integer i
9159       scalar2=u(1)*v(1)+u(2)*v(2)
9160       return
9161       end
9162
9163 C-----------------------------------------------------------------------------
9164
9165       subroutine transpose2(a,at)
9166 !DIR$ INLINEALWAYS transpose2
9167 #ifndef OSF
9168 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9169 #endif
9170       implicit none
9171       double precision a(2,2),at(2,2)
9172       at(1,1)=a(1,1)
9173       at(1,2)=a(2,1)
9174       at(2,1)=a(1,2)
9175       at(2,2)=a(2,2)
9176       return
9177       end
9178 c--------------------------------------------------------------------------
9179       subroutine transpose(n,a,at)
9180       implicit none
9181       integer n,i,j
9182       double precision a(n,n),at(n,n)
9183       do i=1,n
9184         do j=1,n
9185           at(j,i)=a(i,j)
9186         enddo
9187       enddo
9188       return
9189       end
9190 C---------------------------------------------------------------------------
9191       subroutine prodmat3(a1,a2,kk,transp,prod)
9192 !DIR$ INLINEALWAYS prodmat3
9193 #ifndef OSF
9194 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9195 #endif
9196       implicit none
9197       integer i,j
9198       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9199       logical transp
9200 crc      double precision auxmat(2,2),prod_(2,2)
9201
9202       if (transp) then
9203 crc        call transpose2(kk(1,1),auxmat(1,1))
9204 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9205 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9206
9207            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9208      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9209            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9210      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9211            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9212      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9213            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9214      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9215
9216       else
9217 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9218 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9219
9220            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9221      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9222            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9223      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9224            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9225      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9226            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9227      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9228
9229       endif
9230 c      call transpose2(a2(1,1),a2t(1,1))
9231
9232 crc      print *,transp
9233 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9234 crc      print *,((prod(i,j),i=1,2),j=1,2)
9235
9236       return
9237       end
9238