source/unres/src_MD-M-newcorr/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 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)*dsin(theta(i-1)/2.0d0)
2275      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2276      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2277         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2278      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2279      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2280 c     &           +bnew1(3,1,iti)*dsin(alpha(i))*cos(beta(i))
2281 c     &*(cos(theta(i)/2.0)
2282         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2283      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2284      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2285 c     &           +bnew2(3,1,iti)*dsin(alpha(i))*dcos(beta(i))
2286 c     &*(cos(theta(i)/2.0)
2287         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2288      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2289      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
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)*dcos(theta(i)/2.0d0)/2.0d0,
2293 c     &bnew1(2,1,iti)*dcos(theta(i)),
2294 c     &bnew1(3,1,iti)*dsin(theta(i)/2.0d0)/2.0d0
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)*dsin(alpha(i))*dsin(beta(i))
2312 c        b2(2,iti)=bnew2(1,2,iti)*dsin(alpha(i))*dsin(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.gt. nnt+2 .and. i.lt.nct+2) then
2327           iti = itortyp(itype(i-2))
2328         else
2329           iti=ntortyp+1
2330         endif
2331 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2332         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2333           iti1 = itortyp(itype(i-1))
2334         else
2335           iti1=ntortyp+1
2336         endif
2337         if (i .lt. nres+1) then
2338           sin1=dsin(phi(i))
2339           cos1=dcos(phi(i))
2340           sintab(i-2)=sin1
2341           costab(i-2)=cos1
2342           obrot(1,i-2)=cos1
2343           obrot(2,i-2)=sin1
2344           sin2=dsin(2*phi(i))
2345           cos2=dcos(2*phi(i))
2346           sintab2(i-2)=sin2
2347           costab2(i-2)=cos2
2348           obrot2(1,i-2)=cos2
2349           obrot2(2,i-2)=sin2
2350           Ug(1,1,i-2)=-cos1
2351           Ug(1,2,i-2)=-sin1
2352           Ug(2,1,i-2)=-sin1
2353           Ug(2,2,i-2)= cos1
2354           Ug2(1,1,i-2)=-cos2
2355           Ug2(1,2,i-2)=-sin2
2356           Ug2(2,1,i-2)=-sin2
2357           Ug2(2,2,i-2)= cos2
2358         else
2359           costab(i-2)=1.0d0
2360           sintab(i-2)=0.0d0
2361           obrot(1,i-2)=1.0d0
2362           obrot(2,i-2)=0.0d0
2363           obrot2(1,i-2)=0.0d0
2364           obrot2(2,i-2)=0.0d0
2365           Ug(1,1,i-2)=1.0d0
2366           Ug(1,2,i-2)=0.0d0
2367           Ug(2,1,i-2)=0.0d0
2368           Ug(2,2,i-2)=1.0d0
2369           Ug2(1,1,i-2)=0.0d0
2370           Ug2(1,2,i-2)=0.0d0
2371           Ug2(2,1,i-2)=0.0d0
2372           Ug2(2,2,i-2)=0.0d0
2373         endif
2374         if (i .gt. 3 .and. i .lt. nres+1) then
2375           obrot_der(1,i-2)=-sin1
2376           obrot_der(2,i-2)= cos1
2377           Ugder(1,1,i-2)= sin1
2378           Ugder(1,2,i-2)=-cos1
2379           Ugder(2,1,i-2)=-cos1
2380           Ugder(2,2,i-2)=-sin1
2381           dwacos2=cos2+cos2
2382           dwasin2=sin2+sin2
2383           obrot2_der(1,i-2)=-dwasin2
2384           obrot2_der(2,i-2)= dwacos2
2385           Ug2der(1,1,i-2)= dwasin2
2386           Ug2der(1,2,i-2)=-dwacos2
2387           Ug2der(2,1,i-2)=-dwacos2
2388           Ug2der(2,2,i-2)=-dwasin2
2389         else
2390           obrot_der(1,i-2)=0.0d0
2391           obrot_der(2,i-2)=0.0d0
2392           Ugder(1,1,i-2)=0.0d0
2393           Ugder(1,2,i-2)=0.0d0
2394           Ugder(2,1,i-2)=0.0d0
2395           Ugder(2,2,i-2)=0.0d0
2396           obrot2_der(1,i-2)=0.0d0
2397           obrot2_der(2,i-2)=0.0d0
2398           Ug2der(1,1,i-2)=0.0d0
2399           Ug2der(1,2,i-2)=0.0d0
2400           Ug2der(2,1,i-2)=0.0d0
2401           Ug2der(2,2,i-2)=0.0d0
2402         endif
2403 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2404         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2405           iti = itortyp(itype(i-2))
2406         else
2407           iti=ntortyp+1
2408         endif
2409 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2410         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2411           iti1 = itortyp(itype(i-1))
2412         else
2413           iti1=ntortyp+1
2414         endif
2415 cd        write (iout,*) '*******i',i,' iti1',iti
2416 cd        write (iout,*) 'b1',b1(:,iti)
2417 cd        write (iout,*) 'b2',b2(:,iti)
2418 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2419 c        if (i .gt. iatel_s+2) then
2420         if (i .gt. nnt+2) then
2421           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2422 #ifdef NEWCORR
2423           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2424 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2425 #endif
2426 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2427 c     &    EE(1,2,iti),EE(2,2,iti)
2428           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2429           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2430 c          write(iout,*) "Macierz EUG",
2431 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2432 c     &    eug(2,2,i-2)
2433           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2434      &    then
2435           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2436           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2437           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2438           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2439           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2440           endif
2441         else
2442           do k=1,2
2443             Ub2(k,i-2)=0.0d0
2444             Ctobr(k,i-2)=0.0d0
2445             Dtobr2(k,i-2)=0.0d0
2446             do l=1,2
2447               EUg(l,k,i-2)=0.0d0
2448               CUg(l,k,i-2)=0.0d0
2449               DUg(l,k,i-2)=0.0d0
2450               DtUg2(l,k,i-2)=0.0d0
2451             enddo
2452           enddo
2453         endif
2454         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2455         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2456         do k=1,2
2457           muder(k,i-2)=Ub2der(k,i-2)
2458         enddo
2459 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2460         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2461           if (itype(i-1).le.ntyp) then
2462             iti1 = itortyp(itype(i-1))
2463           else
2464             iti1=ntortyp+1
2465           endif
2466         else
2467           iti1=ntortyp+1
2468         endif
2469         do k=1,2
2470           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2471         enddo
2472 #ifdef MUOUT
2473         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2474      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2475      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2476      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2477      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2478      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itortyp(iti))
2479 #endif
2480 cd        write (iout,*) 'mu ',mu(:,i-2)
2481 cd        write (iout,*) 'mu1',mu1(:,i-2)
2482 cd        write (iout,*) 'mu2',mu2(:,i-2)
2483         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2484      &  then
2485         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2486         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2487         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2488         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2489         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2490 C Vectors and matrices dependent on a single virtual-bond dihedral.
2491         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2492         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2493         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2494         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2495         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2496         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2497         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2498         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2499         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2500         endif
2501       enddo
2502 C Matrices dependent on two consecutive virtual-bond dihedrals.
2503 C The order of matrices is from left to right.
2504       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2505      &then
2506 c      do i=max0(ivec_start,2),ivec_end
2507       do i=2,nres-1
2508         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2509         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2510         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2511         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2512         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2513         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2514         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2515         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2516       enddo
2517       endif
2518 #if defined(MPI) && defined(PARMAT)
2519 #ifdef DEBUG
2520 c      if (fg_rank.eq.0) then
2521         write (iout,*) "Arrays UG and UGDER before GATHER"
2522         do i=1,nres-1
2523           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2524      &     ((ug(l,k,i),l=1,2),k=1,2),
2525      &     ((ugder(l,k,i),l=1,2),k=1,2)
2526         enddo
2527         write (iout,*) "Arrays UG2 and UG2DER"
2528         do i=1,nres-1
2529           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2530      &     ((ug2(l,k,i),l=1,2),k=1,2),
2531      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2532         enddo
2533         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2534         do i=1,nres-1
2535           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2536      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2537      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2538         enddo
2539         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2540         do i=1,nres-1
2541           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2542      &     costab(i),sintab(i),costab2(i),sintab2(i)
2543         enddo
2544         write (iout,*) "Array MUDER"
2545         do i=1,nres-1
2546           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2547         enddo
2548 c      endif
2549 #endif
2550       if (nfgtasks.gt.1) then
2551         time00=MPI_Wtime()
2552 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2553 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2554 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2555 #ifdef MATGATHER
2556         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2557      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2558      &   FG_COMM1,IERR)
2559         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2560      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2563      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2564      &   FG_COMM1,IERR)
2565         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2566      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2567      &   FG_COMM1,IERR)
2568         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2569      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2570      &   FG_COMM1,IERR)
2571         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2572      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2573      &   FG_COMM1,IERR)
2574         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2575      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2576      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2577         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2578      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2579      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2580         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2581      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2582      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2583         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2584      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2585      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2586         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2587      &  then
2588         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2589      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2590      &   FG_COMM1,IERR)
2591         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2592      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2593      &   FG_COMM1,IERR)
2594         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2595      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2596      &   FG_COMM1,IERR)
2597        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2598      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2601      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2604      &   ivec_count(fg_rank1),
2605      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2606      &   FG_COMM1,IERR)
2607         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2608      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2609      &   FG_COMM1,IERR)
2610         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2611      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2612      &   FG_COMM1,IERR)
2613         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2614      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2615      &   FG_COMM1,IERR)
2616         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2617      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2618      &   FG_COMM1,IERR)
2619         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2620      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2621      &   FG_COMM1,IERR)
2622         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2623      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2624      &   FG_COMM1,IERR)
2625         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2626      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2629      &   ivec_count(fg_rank1),
2630      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2631      &   FG_COMM1,IERR)
2632         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2633      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2634      &   FG_COMM1,IERR)
2635        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2636      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2637      &   FG_COMM1,IERR)
2638         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2639      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2640      &   FG_COMM1,IERR)
2641        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2642      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2643      &   FG_COMM1,IERR)
2644         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2645      &   ivec_count(fg_rank1),
2646      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2647      &   FG_COMM1,IERR)
2648         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2649      &   ivec_count(fg_rank1),
2650      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2653      &   ivec_count(fg_rank1),
2654      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2655      &   MPI_MAT2,FG_COMM1,IERR)
2656         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2657      &   ivec_count(fg_rank1),
2658      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2659      &   MPI_MAT2,FG_COMM1,IERR)
2660         endif
2661 #else
2662 c Passes matrix info through the ring
2663       isend=fg_rank1
2664       irecv=fg_rank1-1
2665       if (irecv.lt.0) irecv=nfgtasks1-1
2666       iprev=irecv
2667       inext=fg_rank1+1
2668       if (inext.ge.nfgtasks1) inext=0
2669       do i=1,nfgtasks1-1
2670 c        write (iout,*) "isend",isend," irecv",irecv
2671 c        call flush(iout)
2672         lensend=lentyp(isend)
2673         lenrecv=lentyp(irecv)
2674 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2675 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2676 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2677 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2678 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2679 c        write (iout,*) "Gather ROTAT1"
2680 c        call flush(iout)
2681 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2682 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2683 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2684 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2685 c        write (iout,*) "Gather ROTAT2"
2686 c        call flush(iout)
2687         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2688      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2689      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2690      &   iprev,4400+irecv,FG_COMM,status,IERR)
2691 c        write (iout,*) "Gather ROTAT_OLD"
2692 c        call flush(iout)
2693         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2694      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2695      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2696      &   iprev,5500+irecv,FG_COMM,status,IERR)
2697 c        write (iout,*) "Gather PRECOMP11"
2698 c        call flush(iout)
2699         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2700      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2701      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2702      &   iprev,6600+irecv,FG_COMM,status,IERR)
2703 c        write (iout,*) "Gather PRECOMP12"
2704 c        call flush(iout)
2705         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2706      &  then
2707         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2708      &   MPI_ROTAT2(lensend),inext,7700+isend,
2709      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2710      &   iprev,7700+irecv,FG_COMM,status,IERR)
2711 c        write (iout,*) "Gather PRECOMP21"
2712 c        call flush(iout)
2713         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2714      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2715      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2716      &   iprev,8800+irecv,FG_COMM,status,IERR)
2717 c        write (iout,*) "Gather PRECOMP22"
2718 c        call flush(iout)
2719         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2720      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2721      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2722      &   MPI_PRECOMP23(lenrecv),
2723      &   iprev,9900+irecv,FG_COMM,status,IERR)
2724 c        write (iout,*) "Gather PRECOMP23"
2725 c        call flush(iout)
2726         endif
2727         isend=irecv
2728         irecv=irecv-1
2729         if (irecv.lt.0) irecv=nfgtasks1-1
2730       enddo
2731 #endif
2732         time_gather=time_gather+MPI_Wtime()-time00
2733       endif
2734 #ifdef DEBUG
2735 c      if (fg_rank.eq.0) then
2736         write (iout,*) "Arrays UG and UGDER"
2737         do i=1,nres-1
2738           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2739      &     ((ug(l,k,i),l=1,2),k=1,2),
2740      &     ((ugder(l,k,i),l=1,2),k=1,2)
2741         enddo
2742         write (iout,*) "Arrays UG2 and UG2DER"
2743         do i=1,nres-1
2744           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2745      &     ((ug2(l,k,i),l=1,2),k=1,2),
2746      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2747         enddo
2748         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2749         do i=1,nres-1
2750           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2751      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2752      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2753         enddo
2754         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2755         do i=1,nres-1
2756           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2757      &     costab(i),sintab(i),costab2(i),sintab2(i)
2758         enddo
2759         write (iout,*) "Array MUDER"
2760         do i=1,nres-1
2761           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2762         enddo
2763 c      endif
2764 #endif
2765 #endif
2766 cd      do i=1,nres
2767 cd        iti = itortyp(itype(i))
2768 cd        write (iout,*) i
2769 cd        do j=1,2
2770 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2771 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2772 cd        enddo
2773 cd      enddo
2774       return
2775       end
2776 C--------------------------------------------------------------------------
2777       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2778 C
2779 C This subroutine calculates the average interaction energy and its gradient
2780 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2781 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2782 C The potential depends both on the distance of peptide-group centers and on
2783 C the orientation of the CA-CA virtual bonds.
2784 C
2785       implicit real*8 (a-h,o-z)
2786 #ifdef MPI
2787       include 'mpif.h'
2788 #endif
2789       include 'DIMENSIONS'
2790       include 'COMMON.CONTROL'
2791       include 'COMMON.SETUP'
2792       include 'COMMON.IOUNITS'
2793       include 'COMMON.GEO'
2794       include 'COMMON.VAR'
2795       include 'COMMON.LOCAL'
2796       include 'COMMON.CHAIN'
2797       include 'COMMON.DERIV'
2798       include 'COMMON.INTERACT'
2799       include 'COMMON.CONTACTS'
2800       include 'COMMON.TORSION'
2801       include 'COMMON.VECTORS'
2802       include 'COMMON.FFIELD'
2803       include 'COMMON.TIME1'
2804       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2805      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2806       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2807      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2808       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2809      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2810      &    num_conti,j1,j2
2811 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2812 #ifdef MOMENT
2813       double precision scal_el /1.0d0/
2814 #else
2815       double precision scal_el /0.5d0/
2816 #endif
2817 C 12/13/98
2818 C 13-go grudnia roku pamietnego...
2819       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2820      &                   0.0d0,1.0d0,0.0d0,
2821      &                   0.0d0,0.0d0,1.0d0/
2822 cd      write(iout,*) 'In EELEC'
2823 cd      do i=1,nloctyp
2824 cd        write(iout,*) 'Type',i
2825 cd        write(iout,*) 'B1',B1(:,i)
2826 cd        write(iout,*) 'B2',B2(:,i)
2827 cd        write(iout,*) 'CC',CC(:,:,i)
2828 cd        write(iout,*) 'DD',DD(:,:,i)
2829 cd        write(iout,*) 'EE',EE(:,:,i)
2830 cd      enddo
2831 cd      call check_vecgrad
2832 cd      stop
2833       if (icheckgrad.eq.1) then
2834         do i=1,nres-1
2835           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2836           do k=1,3
2837             dc_norm(k,i)=dc(k,i)*fac
2838           enddo
2839 c          write (iout,*) 'i',i,' fac',fac
2840         enddo
2841       endif
2842       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2843      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2844      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2845 c        call vec_and_deriv
2846 #ifdef TIMING
2847         time01=MPI_Wtime()
2848 #endif
2849         call set_matrices
2850 #ifdef TIMING
2851         time_mat=time_mat+MPI_Wtime()-time01
2852 #endif
2853       endif
2854 cd      do i=1,nres-1
2855 cd        write (iout,*) 'i=',i
2856 cd        do k=1,3
2857 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2858 cd        enddo
2859 cd        do k=1,3
2860 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2861 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2862 cd        enddo
2863 cd      enddo
2864       t_eelecij=0.0d0
2865       ees=0.0D0
2866       evdw1=0.0D0
2867       eel_loc=0.0d0
2868       eello_turn3=0.0d0
2869       eello_turn4=0.0d0
2870       ind=0
2871       do i=1,nres
2872         num_cont_hb(i)=0
2873       enddo
2874 cd      print '(a)','Enter EELEC'
2875 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2876       do i=1,nres
2877         gel_loc_loc(i)=0.0d0
2878         gcorr_loc(i)=0.0d0
2879       enddo
2880 c
2881 c
2882 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2883 C
2884 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2885 C
2886       do i=iturn3_start,iturn3_end
2887         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2888      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2889         dxi=dc(1,i)
2890         dyi=dc(2,i)
2891         dzi=dc(3,i)
2892         dx_normi=dc_norm(1,i)
2893         dy_normi=dc_norm(2,i)
2894         dz_normi=dc_norm(3,i)
2895         xmedi=c(1,i)+0.5d0*dxi
2896         ymedi=c(2,i)+0.5d0*dyi
2897         zmedi=c(3,i)+0.5d0*dzi
2898         num_conti=0
2899         call eelecij(i,i+2,ees,evdw1,eel_loc)
2900         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2901         num_cont_hb(i)=num_conti
2902       enddo
2903       do i=iturn4_start,iturn4_end
2904         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2905      &    .or. itype(i+3).eq.ntyp1
2906      &    .or. itype(i+4).eq.ntyp1) cycle
2907         dxi=dc(1,i)
2908         dyi=dc(2,i)
2909         dzi=dc(3,i)
2910         dx_normi=dc_norm(1,i)
2911         dy_normi=dc_norm(2,i)
2912         dz_normi=dc_norm(3,i)
2913         xmedi=c(1,i)+0.5d0*dxi
2914         ymedi=c(2,i)+0.5d0*dyi
2915         zmedi=c(3,i)+0.5d0*dzi
2916         num_conti=num_cont_hb(i)
2917 c        write(iout,*) "JESTEM W PETLI"
2918         call eelecij(i,i+3,ees,evdw1,eel_loc)
2919         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2920      &   call eturn4(i,eello_turn4)
2921         num_cont_hb(i)=num_conti
2922       enddo   ! i
2923 c
2924 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2925 c
2926       do i=iatel_s,iatel_e
2927 c       do i=7,7
2928         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2929         dxi=dc(1,i)
2930         dyi=dc(2,i)
2931         dzi=dc(3,i)
2932         dx_normi=dc_norm(1,i)
2933         dy_normi=dc_norm(2,i)
2934         dz_normi=dc_norm(3,i)
2935         xmedi=c(1,i)+0.5d0*dxi
2936         ymedi=c(2,i)+0.5d0*dyi
2937         zmedi=c(3,i)+0.5d0*dzi
2938 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2939         num_conti=num_cont_hb(i)
2940         do j=ielstart(i),ielend(i)
2941 c         do j=13,13
2942 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2943           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2944           call eelecij(i,j,ees,evdw1,eel_loc)
2945         enddo ! j
2946         num_cont_hb(i)=num_conti
2947       enddo   ! i
2948 c      write (iout,*) "Number of loop steps in EELEC:",ind
2949 cd      do i=1,nres
2950 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2951 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2952 cd      enddo
2953 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2954 ccc      eel_loc=eel_loc+eello_turn3
2955 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2956       return
2957       end
2958 C-------------------------------------------------------------------------------
2959       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2960       implicit real*8 (a-h,o-z)
2961       include 'DIMENSIONS'
2962 #ifdef MPI
2963       include "mpif.h"
2964 #endif
2965       include 'COMMON.CONTROL'
2966       include 'COMMON.IOUNITS'
2967       include 'COMMON.GEO'
2968       include 'COMMON.VAR'
2969       include 'COMMON.LOCAL'
2970       include 'COMMON.CHAIN'
2971       include 'COMMON.DERIV'
2972       include 'COMMON.INTERACT'
2973       include 'COMMON.CONTACTS'
2974       include 'COMMON.TORSION'
2975       include 'COMMON.VECTORS'
2976       include 'COMMON.FFIELD'
2977       include 'COMMON.TIME1'
2978       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2979      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2980       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2981      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2982      &    gmuij2(4),gmuji2(4)
2983       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2984      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2985      &    num_conti,j1,j2
2986 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2987 #ifdef MOMENT
2988       double precision scal_el /1.0d0/
2989 #else
2990       double precision scal_el /0.5d0/
2991 #endif
2992 C 12/13/98
2993 C 13-go grudnia roku pamietnego...
2994       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2995      &                   0.0d0,1.0d0,0.0d0,
2996      &                   0.0d0,0.0d0,1.0d0/
2997 c          time00=MPI_Wtime()
2998 cd      write (iout,*) "eelecij",i,j
2999 c          ind=ind+1
3000           iteli=itel(i)
3001           itelj=itel(j)
3002           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3003           aaa=app(iteli,itelj)
3004           bbb=bpp(iteli,itelj)
3005           ael6i=ael6(iteli,itelj)
3006           ael3i=ael3(iteli,itelj)
3007           dxj=dc(1,j)
3008           dyj=dc(2,j)
3009           dzj=dc(3,j)
3010           dx_normj=dc_norm(1,j)
3011           dy_normj=dc_norm(2,j)
3012           dz_normj=dc_norm(3,j)
3013           xj=c(1,j)+0.5D0*dxj-xmedi
3014           yj=c(2,j)+0.5D0*dyj-ymedi
3015           zj=c(3,j)+0.5D0*dzj-zmedi
3016           rij=xj*xj+yj*yj+zj*zj
3017           rrmij=1.0D0/rij
3018           rij=dsqrt(rij)
3019           rmij=1.0D0/rij
3020           r3ij=rrmij*rmij
3021           r6ij=r3ij*r3ij
3022           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3023           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3024           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3025           fac=cosa-3.0D0*cosb*cosg
3026           ev1=aaa*r6ij*r6ij
3027 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3028           if (j.eq.i+2) ev1=scal_el*ev1
3029           ev2=bbb*r6ij
3030           fac3=ael6i*r6ij
3031           fac4=ael3i*r3ij
3032           evdwij=ev1+ev2
3033           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3034           el2=fac4*fac
3035           eesij=el1+el2
3036 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3037           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3038           ees=ees+eesij
3039           evdw1=evdw1+evdwij
3040 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3041 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3042 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3043 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3044
3045           if (energy_dec) then
3046               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3047      &'evdw1',i,j,evdwij
3048      &,iteli,itelj,aaa,evdw1
3049               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3050           endif
3051
3052 C
3053 C Calculate contributions to the Cartesian gradient.
3054 C
3055 #ifdef SPLITELE
3056           facvdw=-6*rrmij*(ev1+evdwij)
3057           facel=-3*rrmij*(el1+eesij)
3058           fac1=fac
3059           erij(1)=xj*rmij
3060           erij(2)=yj*rmij
3061           erij(3)=zj*rmij
3062 *
3063 * Radial derivatives. First process both termini of the fragment (i,j)
3064 *
3065           ggg(1)=facel*xj
3066           ggg(2)=facel*yj
3067           ggg(3)=facel*zj
3068 c          do k=1,3
3069 c            ghalf=0.5D0*ggg(k)
3070 c            gelc(k,i)=gelc(k,i)+ghalf
3071 c            gelc(k,j)=gelc(k,j)+ghalf
3072 c          enddo
3073 c 9/28/08 AL Gradient compotents will be summed only at the end
3074           do k=1,3
3075             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3076             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3077           enddo
3078 *
3079 * Loop over residues i+1 thru j-1.
3080 *
3081 cgrad          do k=i+1,j-1
3082 cgrad            do l=1,3
3083 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3084 cgrad            enddo
3085 cgrad          enddo
3086           ggg(1)=facvdw*xj
3087           ggg(2)=facvdw*yj
3088           ggg(3)=facvdw*zj
3089 c          do k=1,3
3090 c            ghalf=0.5D0*ggg(k)
3091 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3092 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3093 c          enddo
3094 c 9/28/08 AL Gradient compotents will be summed only at the end
3095           do k=1,3
3096             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3097             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3098           enddo
3099 *
3100 * Loop over residues i+1 thru j-1.
3101 *
3102 cgrad          do k=i+1,j-1
3103 cgrad            do l=1,3
3104 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3105 cgrad            enddo
3106 cgrad          enddo
3107 #else
3108           facvdw=ev1+evdwij
3109           facel=el1+eesij
3110           fac1=fac
3111           fac=-3*rrmij*(facvdw+facvdw+facel)
3112           erij(1)=xj*rmij
3113           erij(2)=yj*rmij
3114           erij(3)=zj*rmij
3115 *
3116 * Radial derivatives. First process both termini of the fragment (i,j)
3117 *
3118           ggg(1)=fac*xj
3119           ggg(2)=fac*yj
3120           ggg(3)=fac*zj
3121 c          do k=1,3
3122 c            ghalf=0.5D0*ggg(k)
3123 c            gelc(k,i)=gelc(k,i)+ghalf
3124 c            gelc(k,j)=gelc(k,j)+ghalf
3125 c          enddo
3126 c 9/28/08 AL Gradient compotents will be summed only at the end
3127           do k=1,3
3128             gelc_long(k,j)=gelc(k,j)+ggg(k)
3129             gelc_long(k,i)=gelc(k,i)-ggg(k)
3130           enddo
3131 *
3132 * Loop over residues i+1 thru j-1.
3133 *
3134 cgrad          do k=i+1,j-1
3135 cgrad            do l=1,3
3136 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3137 cgrad            enddo
3138 cgrad          enddo
3139 c 9/28/08 AL Gradient compotents will be summed only at the end
3140           ggg(1)=facvdw*xj
3141           ggg(2)=facvdw*yj
3142           ggg(3)=facvdw*zj
3143           do k=1,3
3144             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3145             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3146           enddo
3147 #endif
3148 *
3149 * Angular part
3150 *
3151           ecosa=2.0D0*fac3*fac1+fac4
3152           fac4=-3.0D0*fac4
3153           fac3=-6.0D0*fac3
3154           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3155           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3156           do k=1,3
3157             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3158             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3159           enddo
3160 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3161 cd   &          (dcosg(k),k=1,3)
3162           do k=1,3
3163             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3164           enddo
3165 c          do k=1,3
3166 c            ghalf=0.5D0*ggg(k)
3167 c            gelc(k,i)=gelc(k,i)+ghalf
3168 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3169 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3170 c            gelc(k,j)=gelc(k,j)+ghalf
3171 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3172 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3173 c          enddo
3174 cgrad          do k=i+1,j-1
3175 cgrad            do l=1,3
3176 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3177 cgrad            enddo
3178 cgrad          enddo
3179           do k=1,3
3180             gelc(k,i)=gelc(k,i)
3181      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3182      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3183             gelc(k,j)=gelc(k,j)
3184      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3185      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3186             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3187             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3188           enddo
3189           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3190      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3191      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3192 C
3193 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3194 C   energy of a peptide unit is assumed in the form of a second-order
3195 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3196 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3197 C   are computed for EVERY pair of non-contiguous peptide groups.
3198 C
3199
3200           if (j.lt.nres-1) then
3201             j1=j+1
3202             j2=j-1
3203           else
3204             j1=j-1
3205             j2=j-2
3206           endif
3207           kkk=0
3208           lll=0
3209           do k=1,2
3210             do l=1,2
3211               kkk=kkk+1
3212               muij(kkk)=mu(k,i)*mu(l,j)
3213 #ifdef NEWCORR
3214              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3215 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(k,i),k,i
3216              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3217              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3218 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(l,j),l,j
3219              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3220 #endif
3221             enddo
3222           enddo
3223 cd         write (iout,*) 'EELEC: i',i,' j',j
3224 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3225 cd          write(iout,*) 'muij',muij
3226           ury=scalar(uy(1,i),erij)
3227           urz=scalar(uz(1,i),erij)
3228           vry=scalar(uy(1,j),erij)
3229           vrz=scalar(uz(1,j),erij)
3230           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3231           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3232           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3233           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3234           fac=dsqrt(-ael6i)*r3ij
3235           a22=a22*fac
3236           a23=a23*fac
3237           a32=a32*fac
3238           a33=a33*fac
3239 cd          write (iout,'(4i5,4f10.5)')
3240 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3241 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3242 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3243 cd     &      uy(:,j),uz(:,j)
3244 cd          write (iout,'(4f10.5)')
3245 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3246 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3247 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3248 cd           write (iout,'(9f10.5/)')
3249 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3250 C Derivatives of the elements of A in virtual-bond vectors
3251           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3252           do k=1,3
3253             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3254             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3255             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3256             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3257             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3258             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3259             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3260             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3261             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3262             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3263             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3264             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3265           enddo
3266 C Compute radial contributions to the gradient
3267           facr=-3.0d0*rrmij
3268           a22der=a22*facr
3269           a23der=a23*facr
3270           a32der=a32*facr
3271           a33der=a33*facr
3272           agg(1,1)=a22der*xj
3273           agg(2,1)=a22der*yj
3274           agg(3,1)=a22der*zj
3275           agg(1,2)=a23der*xj
3276           agg(2,2)=a23der*yj
3277           agg(3,2)=a23der*zj
3278           agg(1,3)=a32der*xj
3279           agg(2,3)=a32der*yj
3280           agg(3,3)=a32der*zj
3281           agg(1,4)=a33der*xj
3282           agg(2,4)=a33der*yj
3283           agg(3,4)=a33der*zj
3284 C Add the contributions coming from er
3285           fac3=-3.0d0*fac
3286           do k=1,3
3287             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3288             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3289             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3290             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3291           enddo
3292           do k=1,3
3293 C Derivatives in DC(i)
3294 cgrad            ghalf1=0.5d0*agg(k,1)
3295 cgrad            ghalf2=0.5d0*agg(k,2)
3296 cgrad            ghalf3=0.5d0*agg(k,3)
3297 cgrad            ghalf4=0.5d0*agg(k,4)
3298             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3299      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3300             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3301      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3302             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3303      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3304             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3305      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3306 C Derivatives in DC(i+1)
3307             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3308      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3309             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3310      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3311             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3312      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3313             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3314      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3315 C Derivatives in DC(j)
3316             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3317      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3318             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3319      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3320             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3321      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3322             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3323      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3324 C Derivatives in DC(j+1) or DC(nres-1)
3325             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3326      &      -3.0d0*vryg(k,3)*ury)
3327             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3328      &      -3.0d0*vrzg(k,3)*ury)
3329             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3330      &      -3.0d0*vryg(k,3)*urz)
3331             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3332      &      -3.0d0*vrzg(k,3)*urz)
3333 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3334 cgrad              do l=1,4
3335 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3336 cgrad              enddo
3337 cgrad            endif
3338           enddo
3339           acipa(1,1)=a22
3340           acipa(1,2)=a23
3341           acipa(2,1)=a32
3342           acipa(2,2)=a33
3343           a22=-a22
3344           a23=-a23
3345           do l=1,2
3346             do k=1,3
3347               agg(k,l)=-agg(k,l)
3348               aggi(k,l)=-aggi(k,l)
3349               aggi1(k,l)=-aggi1(k,l)
3350               aggj(k,l)=-aggj(k,l)
3351               aggj1(k,l)=-aggj1(k,l)
3352             enddo
3353           enddo
3354           if (j.lt.nres-1) then
3355             a22=-a22
3356             a32=-a32
3357             do l=1,3,2
3358               do k=1,3
3359                 agg(k,l)=-agg(k,l)
3360                 aggi(k,l)=-aggi(k,l)
3361                 aggi1(k,l)=-aggi1(k,l)
3362                 aggj(k,l)=-aggj(k,l)
3363                 aggj1(k,l)=-aggj1(k,l)
3364               enddo
3365             enddo
3366           else
3367             a22=-a22
3368             a23=-a23
3369             a32=-a32
3370             a33=-a33
3371             do l=1,4
3372               do k=1,3
3373                 agg(k,l)=-agg(k,l)
3374                 aggi(k,l)=-aggi(k,l)
3375                 aggi1(k,l)=-aggi1(k,l)
3376                 aggj(k,l)=-aggj(k,l)
3377                 aggj1(k,l)=-aggj1(k,l)
3378               enddo
3379             enddo
3380           endif
3381           ENDIF ! WCORR
3382           IF (wel_loc.gt.0.0d0) THEN
3383 c           if ((i.eq.8).and.(j.eq.14)) then
3384 C Contribution to the local-electrostatic energy coming from the i-j pair
3385           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3386      &     +a33*muij(4)
3387 C Calculate patrial derivative for theta angle
3388 #ifdef NEWCORR
3389          geel_loc_ij=a22*gmuij1(1)
3390      &     +a23*gmuij1(2)
3391      &     +a32*gmuij1(3)
3392      &     +a33*gmuij1(4)
3393 c         write(iout,*) "derivative over thatai"
3394 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3395 c     &   a33*gmuij1(4)
3396          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3397      &      geel_loc_ij*wel_loc
3398 c         write(iout,*) "derivative over thatai-1"
3399 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3400 c     &   a33*gmuij2(4)
3401          geel_loc_ij=a22*gmuij2(1)+a23*gmuij2(2)+a32*gmuij2(3)
3402      &     +a33*gmuij2(4)
3403          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3404      &      geel_loc_ij*wel_loc
3405          geel_loc_ji=a22*gmuji1(1)+a23*gmuji1(2)+a32*gmuji1(3)
3406      &     +a33*gmuji1(4)
3407 c         write(iout,*) "derivative over thataj"
3408 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3409 c     &   a33*gmuji1(4)
3410
3411          gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3412      &      geel_loc_ji*wel_loc
3413          geel_loc_ji=a22*gmuji2(1)+a23*gmuji2(2)+a32*gmuji2(3)
3414      &     +a33*gmuji2(4)
3415 c         write(iout,*) "derivative over thataj-1"
3416 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3417 c     &   a33*gmuji2(4)
3418          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3419      &      geel_loc_ji*wel_loc
3420 #endif
3421 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3422
3423           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3424      &            'eelloc',i,j,eel_loc_ij
3425 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3426
3427           eel_loc=eel_loc+eel_loc_ij
3428 C Partial derivatives in virtual-bond dihedral angles gamma
3429           if (i.gt.1)
3430      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3431      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3432      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3433           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3434      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3435      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3436 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3437           do l=1,3
3438             ggg(l)=agg(l,1)*muij(1)+
3439      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3440             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3441             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3442 cgrad            ghalf=0.5d0*ggg(l)
3443 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3444 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3445           enddo
3446 cgrad          do k=i+1,j2
3447 cgrad            do l=1,3
3448 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3449 cgrad            enddo
3450 cgrad          enddo
3451 C Remaining derivatives of eello
3452           do l=1,3
3453             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3454      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3455             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3456      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3457             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3458      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3459             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3460      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3461           enddo
3462 c          endif
3463           ENDIF
3464 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3465 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3466           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3467      &       .and. num_conti.le.maxconts) then
3468 c            write (iout,*) i,j," entered corr"
3469 C
3470 C Calculate the contact function. The ith column of the array JCONT will
3471 C contain the numbers of atoms that make contacts with the atom I (of numbers
3472 C greater than I). The arrays FACONT and GACONT will contain the values of
3473 C the contact function and its derivative.
3474 c           r0ij=1.02D0*rpp(iteli,itelj)
3475 c           r0ij=1.11D0*rpp(iteli,itelj)
3476             r0ij=2.20D0*rpp(iteli,itelj)
3477 c           r0ij=1.55D0*rpp(iteli,itelj)
3478             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3479             if (fcont.gt.0.0D0) then
3480               num_conti=num_conti+1
3481               if (num_conti.gt.maxconts) then
3482                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3483      &                         ' will skip next contacts for this conf.'
3484               else
3485                 jcont_hb(num_conti,i)=j
3486 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3487 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3488                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3489      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3490 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3491 C  terms.
3492                 d_cont(num_conti,i)=rij
3493 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3494 C     --- Electrostatic-interaction matrix ---
3495                 a_chuj(1,1,num_conti,i)=a22
3496                 a_chuj(1,2,num_conti,i)=a23
3497                 a_chuj(2,1,num_conti,i)=a32
3498                 a_chuj(2,2,num_conti,i)=a33
3499 C     --- Gradient of rij
3500                 do kkk=1,3
3501                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3502                 enddo
3503                 kkll=0
3504                 do k=1,2
3505                   do l=1,2
3506                     kkll=kkll+1
3507                     do m=1,3
3508                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3509                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3510                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3511                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3512                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3513                     enddo
3514                   enddo
3515                 enddo
3516                 ENDIF
3517                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3518 C Calculate contact energies
3519                 cosa4=4.0D0*cosa
3520                 wij=cosa-3.0D0*cosb*cosg
3521                 cosbg1=cosb+cosg
3522                 cosbg2=cosb-cosg
3523 c               fac3=dsqrt(-ael6i)/r0ij**3
3524                 fac3=dsqrt(-ael6i)*r3ij
3525 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3526                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3527                 if (ees0tmp.gt.0) then
3528                   ees0pij=dsqrt(ees0tmp)
3529                 else
3530                   ees0pij=0
3531                 endif
3532 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3533                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3534                 if (ees0tmp.gt.0) then
3535                   ees0mij=dsqrt(ees0tmp)
3536                 else
3537                   ees0mij=0
3538                 endif
3539 c               ees0mij=0.0D0
3540                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3541                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3542 C Diagnostics. Comment out or remove after debugging!
3543 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3544 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3545 c               ees0m(num_conti,i)=0.0D0
3546 C End diagnostics.
3547 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3548 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3549 C Angular derivatives of the contact function
3550                 ees0pij1=fac3/ees0pij
3551                 ees0mij1=fac3/ees0mij
3552                 fac3p=-3.0D0*fac3*rrmij
3553                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3554                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3555 c               ees0mij1=0.0D0
3556                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3557                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3558                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3559                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3560                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3561                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3562                 ecosap=ecosa1+ecosa2
3563                 ecosbp=ecosb1+ecosb2
3564                 ecosgp=ecosg1+ecosg2
3565                 ecosam=ecosa1-ecosa2
3566                 ecosbm=ecosb1-ecosb2
3567                 ecosgm=ecosg1-ecosg2
3568 C Diagnostics
3569 c               ecosap=ecosa1
3570 c               ecosbp=ecosb1
3571 c               ecosgp=ecosg1
3572 c               ecosam=0.0D0
3573 c               ecosbm=0.0D0
3574 c               ecosgm=0.0D0
3575 C End diagnostics
3576                 facont_hb(num_conti,i)=fcont
3577                 fprimcont=fprimcont/rij
3578 cd              facont_hb(num_conti,i)=1.0D0
3579 C Following line is for diagnostics.
3580 cd              fprimcont=0.0D0
3581                 do k=1,3
3582                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3583                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3584                 enddo
3585                 do k=1,3
3586                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3587                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3588                 enddo
3589                 gggp(1)=gggp(1)+ees0pijp*xj
3590                 gggp(2)=gggp(2)+ees0pijp*yj
3591                 gggp(3)=gggp(3)+ees0pijp*zj
3592                 gggm(1)=gggm(1)+ees0mijp*xj
3593                 gggm(2)=gggm(2)+ees0mijp*yj
3594                 gggm(3)=gggm(3)+ees0mijp*zj
3595 C Derivatives due to the contact function
3596                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3597                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3598                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3599                 do k=1,3
3600 c
3601 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3602 c          following the change of gradient-summation algorithm.
3603 c
3604 cgrad                  ghalfp=0.5D0*gggp(k)
3605 cgrad                  ghalfm=0.5D0*gggm(k)
3606                   gacontp_hb1(k,num_conti,i)=!ghalfp
3607      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3608      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3609                   gacontp_hb2(k,num_conti,i)=!ghalfp
3610      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3611      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3612                   gacontp_hb3(k,num_conti,i)=gggp(k)
3613                   gacontm_hb1(k,num_conti,i)=!ghalfm
3614      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3615      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3616                   gacontm_hb2(k,num_conti,i)=!ghalfm
3617      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3618      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3619                   gacontm_hb3(k,num_conti,i)=gggm(k)
3620                 enddo
3621 C Diagnostics. Comment out or remove after debugging!
3622 cdiag           do k=1,3
3623 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3624 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3625 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3626 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3627 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3628 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3629 cdiag           enddo
3630               ENDIF ! wcorr
3631               endif  ! num_conti.le.maxconts
3632             endif  ! fcont.gt.0
3633           endif    ! j.gt.i+1
3634           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3635             do k=1,4
3636               do l=1,3
3637                 ghalf=0.5d0*agg(l,k)
3638                 aggi(l,k)=aggi(l,k)+ghalf
3639                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3640                 aggj(l,k)=aggj(l,k)+ghalf
3641               enddo
3642             enddo
3643             if (j.eq.nres-1 .and. i.lt.j-2) then
3644               do k=1,4
3645                 do l=1,3
3646                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3647                 enddo
3648               enddo
3649             endif
3650           endif
3651 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3652       return
3653       end
3654 C-----------------------------------------------------------------------------
3655       subroutine eturn3(i,eello_turn3)
3656 C Third- and fourth-order contributions from turns
3657       implicit real*8 (a-h,o-z)
3658       include 'DIMENSIONS'
3659       include 'COMMON.IOUNITS'
3660       include 'COMMON.GEO'
3661       include 'COMMON.VAR'
3662       include 'COMMON.LOCAL'
3663       include 'COMMON.CHAIN'
3664       include 'COMMON.DERIV'
3665       include 'COMMON.INTERACT'
3666       include 'COMMON.CONTACTS'
3667       include 'COMMON.TORSION'
3668       include 'COMMON.VECTORS'
3669       include 'COMMON.FFIELD'
3670       include 'COMMON.CONTROL'
3671       dimension ggg(3)
3672       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3673      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3674      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3675      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3676      &  auxgmat2(2,2),auxgmatt2(2,2)
3677       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3678      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3679       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3680      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3681      &    num_conti,j1,j2
3682       j=i+2
3683 c      write (iout,*) "eturn3",i,j,j1,j2
3684       a_temp(1,1)=a22
3685       a_temp(1,2)=a23
3686       a_temp(2,1)=a32
3687       a_temp(2,2)=a33
3688 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3689 C
3690 C               Third-order contributions
3691 C
3692 C                 (i+2)o----(i+3)
3693 C                      | |
3694 C                      | |
3695 C                 (i+1)o----i
3696 C
3697 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3698 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3699         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3700 c auxalary matices for theta gradient
3701 c auxalary matrix for i+1 and constant i+2
3702         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3703 c auxalary matrix for i+2 and constant i+1
3704         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3705         call transpose2(auxmat(1,1),auxmat1(1,1))
3706         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3707         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3708         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3709         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3710         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3711         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3712 C Derivatives in theta
3713         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3714      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3715         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3716      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3717
3718         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3719      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3720 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3721 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3722 cd     &    ' eello_turn3_num',4*eello_turn3_num
3723 C Derivatives in gamma(i)
3724         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3725         call transpose2(auxmat2(1,1),auxmat3(1,1))
3726         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3727         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3728 C Derivatives in gamma(i+1)
3729         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3730         call transpose2(auxmat2(1,1),auxmat3(1,1))
3731         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3732         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3733      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3734 C Cartesian derivatives
3735         do l=1,3
3736 c            ghalf1=0.5d0*agg(l,1)
3737 c            ghalf2=0.5d0*agg(l,2)
3738 c            ghalf3=0.5d0*agg(l,3)
3739 c            ghalf4=0.5d0*agg(l,4)
3740           a_temp(1,1)=aggi(l,1)!+ghalf1
3741           a_temp(1,2)=aggi(l,2)!+ghalf2
3742           a_temp(2,1)=aggi(l,3)!+ghalf3
3743           a_temp(2,2)=aggi(l,4)!+ghalf4
3744           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3745           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3746      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3747           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3748           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3749           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3750           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3751           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3752           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3753      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3754           a_temp(1,1)=aggj(l,1)!+ghalf1
3755           a_temp(1,2)=aggj(l,2)!+ghalf2
3756           a_temp(2,1)=aggj(l,3)!+ghalf3
3757           a_temp(2,2)=aggj(l,4)!+ghalf4
3758           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3759           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3760      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3761           a_temp(1,1)=aggj1(l,1)
3762           a_temp(1,2)=aggj1(l,2)
3763           a_temp(2,1)=aggj1(l,3)
3764           a_temp(2,2)=aggj1(l,4)
3765           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3766           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3767      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3768         enddo
3769       return
3770       end
3771 C-------------------------------------------------------------------------------
3772       subroutine eturn4(i,eello_turn4)
3773 C Third- and fourth-order contributions from turns
3774       implicit real*8 (a-h,o-z)
3775       include 'DIMENSIONS'
3776       include 'COMMON.IOUNITS'
3777       include 'COMMON.GEO'
3778       include 'COMMON.VAR'
3779       include 'COMMON.LOCAL'
3780       include 'COMMON.CHAIN'
3781       include 'COMMON.DERIV'
3782       include 'COMMON.INTERACT'
3783       include 'COMMON.CONTACTS'
3784       include 'COMMON.TORSION'
3785       include 'COMMON.VECTORS'
3786       include 'COMMON.FFIELD'
3787       include 'COMMON.CONTROL'
3788       dimension ggg(3)
3789       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3790      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3791      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3792      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3793      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3794      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3795      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3796       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3797      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3798       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3799      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3800      &    num_conti,j1,j2
3801       j=i+3
3802 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3803 C
3804 C               Fourth-order contributions
3805 C
3806 C                 (i+3)o----(i+4)
3807 C                     /  |
3808 C               (i+2)o   |
3809 C                     \  |
3810 C                 (i+1)o----i
3811 C
3812 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3813 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3814 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3815 c        write(iout,*)"WCHODZE W PROGRAM"
3816         a_temp(1,1)=a22
3817         a_temp(1,2)=a23
3818         a_temp(2,1)=a32
3819         a_temp(2,2)=a33
3820         iti1=itortyp(itype(i+1))
3821         iti2=itortyp(itype(i+2))
3822         iti3=itortyp(itype(i+3))
3823 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3824         call transpose2(EUg(1,1,i+1),e1t(1,1))
3825         call transpose2(Eug(1,1,i+2),e2t(1,1))
3826         call transpose2(Eug(1,1,i+3),e3t(1,1))
3827 C Ematrix derivative in theta
3828         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3829         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3830         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3831         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3832 c       eta1 in derivative theta
3833         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3834         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3835 c       auxgvec is derivative of Ub2 so i+3 theta
3836         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3837 c       auxalary matrix of E i+1
3838         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3839 c        s1=0.0
3840 c        gs1=0.0
3841         s1=scalar2(b1(1,i+2),auxvec(1))
3842 c derivative of theta i+2 with constant i+3
3843         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3844 c derivative of theta i+2 with constant i+2
3845         gs32=scalar2(b1(1,i+2),auxgvec(1))
3846 c derivative of E matix in theta of i+1
3847         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3848
3849         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3850 c       ea31 in derivative theta
3851         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3852         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3853 c auxilary matrix auxgvec of Ub2 with constant E matirx
3854         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3855 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3856         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3857
3858 c        s2=0.0
3859 c        gs2=0.0
3860         s2=scalar2(b1(1,i+1),auxvec(1))
3861 c derivative of theta i+1 with constant i+3
3862         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3863 c derivative of theta i+2 with constant i+1
3864         gs21=scalar2(b1(1,i+1),auxgvec(1))
3865 c derivative of theta i+3 with constant i+1
3866         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3867 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3868 c     &  gtb1(1,i+1)
3869         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3870 c two derivatives over diffetent matrices
3871 c gtae3e2 is derivative over i+3
3872         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3873 c ae3gte2 is derivative over i+2
3874         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3875         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3876 c three possible derivative over theta E matices
3877 c i+1
3878         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3879 c i+2
3880         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3881 c i+3
3882         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3883         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3884
3885         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3886         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3887         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3888
3889         eello_turn4=eello_turn4-(s1+s2+s3)
3890 #ifdef NEWCORR
3891         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3892      &                  -(gs13+gsE13+gsEE1)*wturn4
3893         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3894      &                    -(gs23+gs21+gsEE2)*wturn4
3895         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3896      &                    -(gs32+gsE31+gsEE3)*wturn4
3897 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3898 c     &   gs2
3899 #endif
3900         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3901      &      'eturn4',i,j,-(s1+s2+s3)
3902 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3903 c     &    ' eello_turn4_num',8*eello_turn4_num
3904 C Derivatives in gamma(i)
3905         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3906         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3907         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3908         s1=scalar2(b1(1,i+2),auxvec(1))
3909         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3910         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3911         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3912 C Derivatives in gamma(i+1)
3913         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3914         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3915         s2=scalar2(b1(1,i+1),auxvec(1))
3916         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3917         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3918         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3919         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3920 C Derivatives in gamma(i+2)
3921         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3922         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3923         s1=scalar2(b1(1,i+2),auxvec(1))
3924         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3925         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3926         s2=scalar2(b1(1,i+1),auxvec(1))
3927         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3928         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3929         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3930         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3931 C Cartesian derivatives
3932 C Derivatives of this turn contributions in DC(i+2)
3933         if (j.lt.nres-1) then
3934           do l=1,3
3935             a_temp(1,1)=agg(l,1)
3936             a_temp(1,2)=agg(l,2)
3937             a_temp(2,1)=agg(l,3)
3938             a_temp(2,2)=agg(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             ggg(l)=-(s1+s2+s3)
3949             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3950           enddo
3951         endif
3952 C Remaining derivatives of this turn contribution
3953         do l=1,3
3954           a_temp(1,1)=aggi(l,1)
3955           a_temp(1,2)=aggi(l,2)
3956           a_temp(2,1)=aggi(l,3)
3957           a_temp(2,2)=aggi(l,4)
3958           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3959           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3960           s1=scalar2(b1(1,i+2),auxvec(1))
3961           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3962           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3963           s2=scalar2(b1(1,i+1),auxvec(1))
3964           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3965           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3966           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3967           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3968           a_temp(1,1)=aggi1(l,1)
3969           a_temp(1,2)=aggi1(l,2)
3970           a_temp(2,1)=aggi1(l,3)
3971           a_temp(2,2)=aggi1(l,4)
3972           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3973           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3974           s1=scalar2(b1(1,i+2),auxvec(1))
3975           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3976           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3977           s2=scalar2(b1(1,i+1),auxvec(1))
3978           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3979           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3980           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3981           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3982           a_temp(1,1)=aggj(l,1)
3983           a_temp(1,2)=aggj(l,2)
3984           a_temp(2,1)=aggj(l,3)
3985           a_temp(2,2)=aggj(l,4)
3986           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3987           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3988           s1=scalar2(b1(1,i+2),auxvec(1))
3989           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3990           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3991           s2=scalar2(b1(1,i+1),auxvec(1))
3992           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3993           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3994           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3995           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3996           a_temp(1,1)=aggj1(l,1)
3997           a_temp(1,2)=aggj1(l,2)
3998           a_temp(2,1)=aggj1(l,3)
3999           a_temp(2,2)=aggj1(l,4)
4000           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4001           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4002           s1=scalar2(b1(1,i+2),auxvec(1))
4003           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4004           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4005           s2=scalar2(b1(1,i+1),auxvec(1))
4006           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4007           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4008           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4009 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4010           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4011         enddo
4012       return
4013       end
4014 C-----------------------------------------------------------------------------
4015       subroutine vecpr(u,v,w)
4016       implicit real*8(a-h,o-z)
4017       dimension u(3),v(3),w(3)
4018       w(1)=u(2)*v(3)-u(3)*v(2)
4019       w(2)=-u(1)*v(3)+u(3)*v(1)
4020       w(3)=u(1)*v(2)-u(2)*v(1)
4021       return
4022       end
4023 C-----------------------------------------------------------------------------
4024       subroutine unormderiv(u,ugrad,unorm,ungrad)
4025 C This subroutine computes the derivatives of a normalized vector u, given
4026 C the derivatives computed without normalization conditions, ugrad. Returns
4027 C ungrad.
4028       implicit none
4029       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4030       double precision vec(3)
4031       double precision scalar
4032       integer i,j
4033 c      write (2,*) 'ugrad',ugrad
4034 c      write (2,*) 'u',u
4035       do i=1,3
4036         vec(i)=scalar(ugrad(1,i),u(1))
4037       enddo
4038 c      write (2,*) 'vec',vec
4039       do i=1,3
4040         do j=1,3
4041           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4042         enddo
4043       enddo
4044 c      write (2,*) 'ungrad',ungrad
4045       return
4046       end
4047 C-----------------------------------------------------------------------------
4048       subroutine escp_soft_sphere(evdw2,evdw2_14)
4049 C
4050 C This subroutine calculates the excluded-volume interaction energy between
4051 C peptide-group centers and side chains and its gradient in virtual-bond and
4052 C side-chain vectors.
4053 C
4054       implicit real*8 (a-h,o-z)
4055       include 'DIMENSIONS'
4056       include 'COMMON.GEO'
4057       include 'COMMON.VAR'
4058       include 'COMMON.LOCAL'
4059       include 'COMMON.CHAIN'
4060       include 'COMMON.DERIV'
4061       include 'COMMON.INTERACT'
4062       include 'COMMON.FFIELD'
4063       include 'COMMON.IOUNITS'
4064       include 'COMMON.CONTROL'
4065       dimension ggg(3)
4066       evdw2=0.0D0
4067       evdw2_14=0.0d0
4068       r0_scp=4.5d0
4069 cd    print '(a)','Enter ESCP'
4070 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4071       do i=iatscp_s,iatscp_e
4072         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4073         iteli=itel(i)
4074         xi=0.5D0*(c(1,i)+c(1,i+1))
4075         yi=0.5D0*(c(2,i)+c(2,i+1))
4076         zi=0.5D0*(c(3,i)+c(3,i+1))
4077
4078         do iint=1,nscp_gr(i)
4079
4080         do j=iscpstart(i,iint),iscpend(i,iint)
4081           if (itype(j).eq.ntyp1) cycle
4082           itypj=iabs(itype(j))
4083 C Uncomment following three lines for SC-p interactions
4084 c         xj=c(1,nres+j)-xi
4085 c         yj=c(2,nres+j)-yi
4086 c         zj=c(3,nres+j)-zi
4087 C Uncomment following three lines for Ca-p interactions
4088           xj=c(1,j)-xi
4089           yj=c(2,j)-yi
4090           zj=c(3,j)-zi
4091           rij=xj*xj+yj*yj+zj*zj
4092           r0ij=r0_scp
4093           r0ijsq=r0ij*r0ij
4094           if (rij.lt.r0ijsq) then
4095             evdwij=0.25d0*(rij-r0ijsq)**2
4096             fac=rij-r0ijsq
4097           else
4098             evdwij=0.0d0
4099             fac=0.0d0
4100           endif
4101           evdw2=evdw2+evdwij
4102 C
4103 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4104 C
4105           ggg(1)=xj*fac
4106           ggg(2)=yj*fac
4107           ggg(3)=zj*fac
4108 cgrad          if (j.lt.i) then
4109 cd          write (iout,*) 'j<i'
4110 C Uncomment following three lines for SC-p interactions
4111 c           do k=1,3
4112 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4113 c           enddo
4114 cgrad          else
4115 cd          write (iout,*) 'j>i'
4116 cgrad            do k=1,3
4117 cgrad              ggg(k)=-ggg(k)
4118 C Uncomment following line for SC-p interactions
4119 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4120 cgrad            enddo
4121 cgrad          endif
4122 cgrad          do k=1,3
4123 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4124 cgrad          enddo
4125 cgrad          kstart=min0(i+1,j)
4126 cgrad          kend=max0(i-1,j-1)
4127 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4128 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4129 cgrad          do k=kstart,kend
4130 cgrad            do l=1,3
4131 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4132 cgrad            enddo
4133 cgrad          enddo
4134           do k=1,3
4135             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4136             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4137           enddo
4138         enddo
4139
4140         enddo ! iint
4141       enddo ! i
4142       return
4143       end
4144 C-----------------------------------------------------------------------------
4145       subroutine escp(evdw2,evdw2_14)
4146 C
4147 C This subroutine calculates the excluded-volume interaction energy between
4148 C peptide-group centers and side chains and its gradient in virtual-bond and
4149 C side-chain vectors.
4150 C
4151       implicit real*8 (a-h,o-z)
4152       include 'DIMENSIONS'
4153       include 'COMMON.GEO'
4154       include 'COMMON.VAR'
4155       include 'COMMON.LOCAL'
4156       include 'COMMON.CHAIN'
4157       include 'COMMON.DERIV'
4158       include 'COMMON.INTERACT'
4159       include 'COMMON.FFIELD'
4160       include 'COMMON.IOUNITS'
4161       include 'COMMON.CONTROL'
4162       dimension ggg(3)
4163       evdw2=0.0D0
4164       evdw2_14=0.0d0
4165 cd    print '(a)','Enter ESCP'
4166 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4167       do i=iatscp_s,iatscp_e
4168         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4169         iteli=itel(i)
4170         xi=0.5D0*(c(1,i)+c(1,i+1))
4171         yi=0.5D0*(c(2,i)+c(2,i+1))
4172         zi=0.5D0*(c(3,i)+c(3,i+1))
4173
4174         do iint=1,nscp_gr(i)
4175
4176         do j=iscpstart(i,iint),iscpend(i,iint)
4177           itypj=iabs(itype(j))
4178           if (itypj.eq.ntyp1) cycle
4179 C Uncomment following three lines for SC-p interactions
4180 c         xj=c(1,nres+j)-xi
4181 c         yj=c(2,nres+j)-yi
4182 c         zj=c(3,nres+j)-zi
4183 C Uncomment following three lines for Ca-p interactions
4184           xj=c(1,j)-xi
4185           yj=c(2,j)-yi
4186           zj=c(3,j)-zi
4187           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4188           fac=rrij**expon2
4189           e1=fac*fac*aad(itypj,iteli)
4190           e2=fac*bad(itypj,iteli)
4191           if (iabs(j-i) .le. 2) then
4192             e1=scal14*e1
4193             e2=scal14*e2
4194             evdw2_14=evdw2_14+e1+e2
4195           endif
4196           evdwij=e1+e2
4197           evdw2=evdw2+evdwij
4198           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4199      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4200      &       bad(itypj,iteli)
4201 C
4202 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4203 C
4204           fac=-(evdwij+e1)*rrij
4205           ggg(1)=xj*fac
4206           ggg(2)=yj*fac
4207           ggg(3)=zj*fac
4208 cgrad          if (j.lt.i) then
4209 cd          write (iout,*) 'j<i'
4210 C Uncomment following three lines for SC-p interactions
4211 c           do k=1,3
4212 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4213 c           enddo
4214 cgrad          else
4215 cd          write (iout,*) 'j>i'
4216 cgrad            do k=1,3
4217 cgrad              ggg(k)=-ggg(k)
4218 C Uncomment following line for SC-p interactions
4219 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4220 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4221 cgrad            enddo
4222 cgrad          endif
4223 cgrad          do k=1,3
4224 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4225 cgrad          enddo
4226 cgrad          kstart=min0(i+1,j)
4227 cgrad          kend=max0(i-1,j-1)
4228 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4229 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4230 cgrad          do k=kstart,kend
4231 cgrad            do l=1,3
4232 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4233 cgrad            enddo
4234 cgrad          enddo
4235           do k=1,3
4236             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4237             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4238           enddo
4239         enddo
4240
4241         enddo ! iint
4242       enddo ! i
4243       do i=1,nct
4244         do j=1,3
4245           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4246           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4247           gradx_scp(j,i)=expon*gradx_scp(j,i)
4248         enddo
4249       enddo
4250 C******************************************************************************
4251 C
4252 C                              N O T E !!!
4253 C
4254 C To save time the factor EXPON has been extracted from ALL components
4255 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4256 C use!
4257 C
4258 C******************************************************************************
4259       return
4260       end
4261 C--------------------------------------------------------------------------
4262       subroutine edis(ehpb)
4263 C
4264 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4265 C
4266       implicit real*8 (a-h,o-z)
4267       include 'DIMENSIONS'
4268       include 'COMMON.SBRIDGE'
4269       include 'COMMON.CHAIN'
4270       include 'COMMON.DERIV'
4271       include 'COMMON.VAR'
4272       include 'COMMON.INTERACT'
4273       include 'COMMON.IOUNITS'
4274       dimension ggg(3)
4275       ehpb=0.0D0
4276 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4277 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4278       if (link_end.eq.0) return
4279       do i=link_start,link_end
4280 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4281 C CA-CA distance used in regularization of structure.
4282         ii=ihpb(i)
4283         jj=jhpb(i)
4284 C iii and jjj point to the residues for which the distance is assigned.
4285         if (ii.gt.nres) then
4286           iii=ii-nres
4287           jjj=jj-nres
4288         else
4289           iii=ii
4290           jjj=jj
4291         endif
4292 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4293 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4294 C    distance and angle dependent SS bond potential.
4295         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4296      & iabs(itype(jjj)).eq.1) then
4297           call ssbond_ene(iii,jjj,eij)
4298           ehpb=ehpb+2*eij
4299 cd          write (iout,*) "eij",eij
4300         else
4301 C Calculate the distance between the two points and its difference from the
4302 C target distance.
4303         dd=dist(ii,jj)
4304         rdis=dd-dhpb(i)
4305 C Get the force constant corresponding to this distance.
4306         waga=forcon(i)
4307 C Calculate the contribution to energy.
4308         ehpb=ehpb+waga*rdis*rdis
4309 C
4310 C Evaluate gradient.
4311 C
4312         fac=waga*rdis/dd
4313 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4314 cd   &   ' waga=',waga,' fac=',fac
4315         do j=1,3
4316           ggg(j)=fac*(c(j,jj)-c(j,ii))
4317         enddo
4318 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4319 C If this is a SC-SC distance, we need to calculate the contributions to the
4320 C Cartesian gradient in the SC vectors (ghpbx).
4321         if (iii.lt.ii) then
4322           do j=1,3
4323             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4324             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4325           enddo
4326         endif
4327 cgrad        do j=iii,jjj-1
4328 cgrad          do k=1,3
4329 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4330 cgrad          enddo
4331 cgrad        enddo
4332         do k=1,3
4333           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4334           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4335         enddo
4336         endif
4337       enddo
4338       ehpb=0.5D0*ehpb
4339       return
4340       end
4341 C--------------------------------------------------------------------------
4342       subroutine ssbond_ene(i,j,eij)
4343 C
4344 C Calculate the distance and angle dependent SS-bond potential energy
4345 C using a free-energy function derived based on RHF/6-31G** ab initio
4346 C calculations of diethyl disulfide.
4347 C
4348 C A. Liwo and U. Kozlowska, 11/24/03
4349 C
4350       implicit real*8 (a-h,o-z)
4351       include 'DIMENSIONS'
4352       include 'COMMON.SBRIDGE'
4353       include 'COMMON.CHAIN'
4354       include 'COMMON.DERIV'
4355       include 'COMMON.LOCAL'
4356       include 'COMMON.INTERACT'
4357       include 'COMMON.VAR'
4358       include 'COMMON.IOUNITS'
4359       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4360       itypi=iabs(itype(i))
4361       xi=c(1,nres+i)
4362       yi=c(2,nres+i)
4363       zi=c(3,nres+i)
4364       dxi=dc_norm(1,nres+i)
4365       dyi=dc_norm(2,nres+i)
4366       dzi=dc_norm(3,nres+i)
4367 c      dsci_inv=dsc_inv(itypi)
4368       dsci_inv=vbld_inv(nres+i)
4369       itypj=iabs(itype(j))
4370 c      dscj_inv=dsc_inv(itypj)
4371       dscj_inv=vbld_inv(nres+j)
4372       xj=c(1,nres+j)-xi
4373       yj=c(2,nres+j)-yi
4374       zj=c(3,nres+j)-zi
4375       dxj=dc_norm(1,nres+j)
4376       dyj=dc_norm(2,nres+j)
4377       dzj=dc_norm(3,nres+j)
4378       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4379       rij=dsqrt(rrij)
4380       erij(1)=xj*rij
4381       erij(2)=yj*rij
4382       erij(3)=zj*rij
4383       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4384       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4385       om12=dxi*dxj+dyi*dyj+dzi*dzj
4386       do k=1,3
4387         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4388         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4389       enddo
4390       rij=1.0d0/rij
4391       deltad=rij-d0cm
4392       deltat1=1.0d0-om1
4393       deltat2=1.0d0+om2
4394       deltat12=om2-om1+2.0d0
4395       cosphi=om12-om1*om2
4396       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4397      &  +akct*deltad*deltat12
4398      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4399 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4400 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4401 c     &  " deltat12",deltat12," eij",eij
4402       ed=2*akcm*deltad+akct*deltat12
4403       pom1=akct*deltad
4404       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4405       eom1=-2*akth*deltat1-pom1-om2*pom2
4406       eom2= 2*akth*deltat2+pom1-om1*pom2
4407       eom12=pom2
4408       do k=1,3
4409         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4410         ghpbx(k,i)=ghpbx(k,i)-ggk
4411      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4412      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4413         ghpbx(k,j)=ghpbx(k,j)+ggk
4414      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4415      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4416         ghpbc(k,i)=ghpbc(k,i)-ggk
4417         ghpbc(k,j)=ghpbc(k,j)+ggk
4418       enddo
4419 C
4420 C Calculate the components of the gradient in DC and X
4421 C
4422 cgrad      do k=i,j-1
4423 cgrad        do l=1,3
4424 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4425 cgrad        enddo
4426 cgrad      enddo
4427       return
4428       end
4429 C--------------------------------------------------------------------------
4430       subroutine ebond(estr)
4431 c
4432 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4433 c
4434       implicit real*8 (a-h,o-z)
4435       include 'DIMENSIONS'
4436       include 'COMMON.LOCAL'
4437       include 'COMMON.GEO'
4438       include 'COMMON.INTERACT'
4439       include 'COMMON.DERIV'
4440       include 'COMMON.VAR'
4441       include 'COMMON.CHAIN'
4442       include 'COMMON.IOUNITS'
4443       include 'COMMON.NAMES'
4444       include 'COMMON.FFIELD'
4445       include 'COMMON.CONTROL'
4446       include 'COMMON.SETUP'
4447       double precision u(3),ud(3)
4448       estr=0.0d0
4449       estr1=0.0d0
4450       do i=ibondp_start,ibondp_end
4451         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4452           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4453           do j=1,3
4454           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4455      &      *dc(j,i-1)/vbld(i)
4456           enddo
4457           if (energy_dec) write(iout,*)
4458      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4459         else
4460         diff = vbld(i)-vbldp0
4461         if (energy_dec) write (iout,*)
4462      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4463         estr=estr+diff*diff
4464         do j=1,3
4465           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4466         enddo
4467 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4468         endif
4469       enddo
4470       estr=0.5d0*AKP*estr+estr1
4471 c
4472 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4473 c
4474       do i=ibond_start,ibond_end
4475         iti=iabs(itype(i))
4476         if (iti.ne.10 .and. iti.ne.ntyp1) then
4477           nbi=nbondterm(iti)
4478           if (nbi.eq.1) then
4479             diff=vbld(i+nres)-vbldsc0(1,iti)
4480             if (energy_dec) write (iout,*)
4481      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4482      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4483             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4484             do j=1,3
4485               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4486             enddo
4487           else
4488             do j=1,nbi
4489               diff=vbld(i+nres)-vbldsc0(j,iti)
4490               ud(j)=aksc(j,iti)*diff
4491               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4492             enddo
4493             uprod=u(1)
4494             do j=2,nbi
4495               uprod=uprod*u(j)
4496             enddo
4497             usum=0.0d0
4498             usumsqder=0.0d0
4499             do j=1,nbi
4500               uprod1=1.0d0
4501               uprod2=1.0d0
4502               do k=1,nbi
4503                 if (k.ne.j) then
4504                   uprod1=uprod1*u(k)
4505                   uprod2=uprod2*u(k)*u(k)
4506                 endif
4507               enddo
4508               usum=usum+uprod1
4509               usumsqder=usumsqder+ud(j)*uprod2
4510             enddo
4511             estr=estr+uprod/usum
4512             do j=1,3
4513              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4514             enddo
4515           endif
4516         endif
4517       enddo
4518       return
4519       end
4520 #ifdef CRYST_THETA
4521 C--------------------------------------------------------------------------
4522       subroutine ebend(etheta)
4523 C
4524 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4525 C angles gamma and its derivatives in consecutive thetas and gammas.
4526 C
4527       implicit real*8 (a-h,o-z)
4528       include 'DIMENSIONS'
4529       include 'COMMON.LOCAL'
4530       include 'COMMON.GEO'
4531       include 'COMMON.INTERACT'
4532       include 'COMMON.DERIV'
4533       include 'COMMON.VAR'
4534       include 'COMMON.CHAIN'
4535       include 'COMMON.IOUNITS'
4536       include 'COMMON.NAMES'
4537       include 'COMMON.FFIELD'
4538       include 'COMMON.CONTROL'
4539       common /calcthet/ term1,term2,termm,diffak,ratak,
4540      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4541      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4542       double precision y(2),z(2)
4543       delta=0.02d0*pi
4544 c      time11=dexp(-2*time)
4545 c      time12=1.0d0
4546       etheta=0.0D0
4547 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4548       do i=ithet_start,ithet_end
4549         if (itype(i-1).eq.ntyp1) cycle
4550 C Zero the energy function and its derivative at 0 or pi.
4551         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4552         it=itype(i-1)
4553         ichir1=isign(1,itype(i-2))
4554         ichir2=isign(1,itype(i))
4555          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4556          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4557          if (itype(i-1).eq.10) then
4558           itype1=isign(10,itype(i-2))
4559           ichir11=isign(1,itype(i-2))
4560           ichir12=isign(1,itype(i-2))
4561           itype2=isign(10,itype(i))
4562           ichir21=isign(1,itype(i))
4563           ichir22=isign(1,itype(i))
4564          endif
4565
4566         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4567 #ifdef OSF
4568           phii=phi(i)
4569           if (phii.ne.phii) phii=150.0
4570 #else
4571           phii=phi(i)
4572 #endif
4573           y(1)=dcos(phii)
4574           y(2)=dsin(phii)
4575         else
4576           y(1)=0.0D0
4577           y(2)=0.0D0
4578         endif
4579         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4580 #ifdef OSF
4581           phii1=phi(i+1)
4582           if (phii1.ne.phii1) phii1=150.0
4583           phii1=pinorm(phii1)
4584           z(1)=cos(phii1)
4585 #else
4586           phii1=phi(i+1)
4587           z(1)=dcos(phii1)
4588 #endif
4589           z(2)=dsin(phii1)
4590         else
4591           z(1)=0.0D0
4592           z(2)=0.0D0
4593         endif
4594 C Calculate the "mean" value of theta from the part of the distribution
4595 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4596 C In following comments this theta will be referred to as t_c.
4597         thet_pred_mean=0.0d0
4598         do k=1,2
4599             athetk=athet(k,it,ichir1,ichir2)
4600             bthetk=bthet(k,it,ichir1,ichir2)
4601           if (it.eq.10) then
4602              athetk=athet(k,itype1,ichir11,ichir12)
4603              bthetk=bthet(k,itype2,ichir21,ichir22)
4604           endif
4605          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4606         enddo
4607         dthett=thet_pred_mean*ssd
4608         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4609 C Derivatives of the "mean" values in gamma1 and gamma2.
4610         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4611      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4612          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4613      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4614          if (it.eq.10) then
4615       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4616      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4617         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4618      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4619          endif
4620         if (theta(i).gt.pi-delta) then
4621           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4622      &         E_tc0)
4623           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4624           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4625           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4626      &        E_theta)
4627           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4628      &        E_tc)
4629         else if (theta(i).lt.delta) then
4630           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4631           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4632           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4633      &        E_theta)
4634           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4635           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4636      &        E_tc)
4637         else
4638           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4639      &        E_theta,E_tc)
4640         endif
4641         etheta=etheta+ethetai
4642         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4643      &      'ebend',i,ethetai
4644         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4645         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4646         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4647       enddo
4648 C Ufff.... We've done all this!!!
4649       return
4650       end
4651 C---------------------------------------------------------------------------
4652       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4653      &     E_tc)
4654       implicit real*8 (a-h,o-z)
4655       include 'DIMENSIONS'
4656       include 'COMMON.LOCAL'
4657       include 'COMMON.IOUNITS'
4658       common /calcthet/ term1,term2,termm,diffak,ratak,
4659      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4660      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4661 C Calculate the contributions to both Gaussian lobes.
4662 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4663 C The "polynomial part" of the "standard deviation" of this part of
4664 C the distribution.
4665         sig=polthet(3,it)
4666         do j=2,0,-1
4667           sig=sig*thet_pred_mean+polthet(j,it)
4668         enddo
4669 C Derivative of the "interior part" of the "standard deviation of the"
4670 C gamma-dependent Gaussian lobe in t_c.
4671         sigtc=3*polthet(3,it)
4672         do j=2,1,-1
4673           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4674         enddo
4675         sigtc=sig*sigtc
4676 C Set the parameters of both Gaussian lobes of the distribution.
4677 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4678         fac=sig*sig+sigc0(it)
4679         sigcsq=fac+fac
4680         sigc=1.0D0/sigcsq
4681 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4682         sigsqtc=-4.0D0*sigcsq*sigtc
4683 c       print *,i,sig,sigtc,sigsqtc
4684 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4685         sigtc=-sigtc/(fac*fac)
4686 C Following variable is sigma(t_c)**(-2)
4687         sigcsq=sigcsq*sigcsq
4688         sig0i=sig0(it)
4689         sig0inv=1.0D0/sig0i**2
4690         delthec=thetai-thet_pred_mean
4691         delthe0=thetai-theta0i
4692         term1=-0.5D0*sigcsq*delthec*delthec
4693         term2=-0.5D0*sig0inv*delthe0*delthe0
4694 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4695 C NaNs in taking the logarithm. We extract the largest exponent which is added
4696 C to the energy (this being the log of the distribution) at the end of energy
4697 C term evaluation for this virtual-bond angle.
4698         if (term1.gt.term2) then
4699           termm=term1
4700           term2=dexp(term2-termm)
4701           term1=1.0d0
4702         else
4703           termm=term2
4704           term1=dexp(term1-termm)
4705           term2=1.0d0
4706         endif
4707 C The ratio between the gamma-independent and gamma-dependent lobes of
4708 C the distribution is a Gaussian function of thet_pred_mean too.
4709         diffak=gthet(2,it)-thet_pred_mean
4710         ratak=diffak/gthet(3,it)**2
4711         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4712 C Let's differentiate it in thet_pred_mean NOW.
4713         aktc=ak*ratak
4714 C Now put together the distribution terms to make complete distribution.
4715         termexp=term1+ak*term2
4716         termpre=sigc+ak*sig0i
4717 C Contribution of the bending energy from this theta is just the -log of
4718 C the sum of the contributions from the two lobes and the pre-exponential
4719 C factor. Simple enough, isn't it?
4720         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4721 C NOW the derivatives!!!
4722 C 6/6/97 Take into account the deformation.
4723         E_theta=(delthec*sigcsq*term1
4724      &       +ak*delthe0*sig0inv*term2)/termexp
4725         E_tc=((sigtc+aktc*sig0i)/termpre
4726      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4727      &       aktc*term2)/termexp)
4728       return
4729       end
4730 c-----------------------------------------------------------------------------
4731       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4732       implicit real*8 (a-h,o-z)
4733       include 'DIMENSIONS'
4734       include 'COMMON.LOCAL'
4735       include 'COMMON.IOUNITS'
4736       common /calcthet/ term1,term2,termm,diffak,ratak,
4737      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4738      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4739       delthec=thetai-thet_pred_mean
4740       delthe0=thetai-theta0i
4741 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4742       t3 = thetai-thet_pred_mean
4743       t6 = t3**2
4744       t9 = term1
4745       t12 = t3*sigcsq
4746       t14 = t12+t6*sigsqtc
4747       t16 = 1.0d0
4748       t21 = thetai-theta0i
4749       t23 = t21**2
4750       t26 = term2
4751       t27 = t21*t26
4752       t32 = termexp
4753       t40 = t32**2
4754       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4755      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4756      & *(-t12*t9-ak*sig0inv*t27)
4757       return
4758       end
4759 #else
4760 C--------------------------------------------------------------------------
4761       subroutine ebend(etheta)
4762 C
4763 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4764 C angles gamma and its derivatives in consecutive thetas and gammas.
4765 C ab initio-derived potentials from
4766 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4767 C
4768       implicit real*8 (a-h,o-z)
4769       include 'DIMENSIONS'
4770       include 'COMMON.LOCAL'
4771       include 'COMMON.GEO'
4772       include 'COMMON.INTERACT'
4773       include 'COMMON.DERIV'
4774       include 'COMMON.VAR'
4775       include 'COMMON.CHAIN'
4776       include 'COMMON.IOUNITS'
4777       include 'COMMON.NAMES'
4778       include 'COMMON.FFIELD'
4779       include 'COMMON.CONTROL'
4780       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4781      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4782      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4783      & sinph1ph2(maxdouble,maxdouble)
4784       logical lprn /.false./, lprn1 /.false./
4785       etheta=0.0D0
4786       do i=ithet_start,ithet_end
4787         if (itype(i-1).eq.ntyp1) cycle
4788         if (iabs(itype(i+1)).eq.20) iblock=2
4789         if (iabs(itype(i+1)).ne.20) iblock=1
4790         dethetai=0.0d0
4791         dephii=0.0d0
4792         dephii1=0.0d0
4793         theti2=0.5d0*theta(i)
4794         ityp2=ithetyp((itype(i-1)))
4795         do k=1,nntheterm
4796           coskt(k)=dcos(k*theti2)
4797           sinkt(k)=dsin(k*theti2)
4798         enddo
4799         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4800 #ifdef OSF
4801           phii=phi(i)
4802           if (phii.ne.phii) phii=150.0
4803 #else
4804           phii=phi(i)
4805 #endif
4806           ityp1=ithetyp((itype(i-2)))
4807 C propagation of chirality for glycine type
4808           do k=1,nsingle
4809             cosph1(k)=dcos(k*phii)
4810             sinph1(k)=dsin(k*phii)
4811           enddo
4812         else
4813           phii=0.0d0
4814           ityp1=nthetyp+1
4815           do k=1,nsingle
4816             cosph1(k)=0.0d0
4817             sinph1(k)=0.0d0
4818           enddo
4819         endif
4820         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4821 #ifdef OSF
4822           phii1=phi(i+1)
4823           if (phii1.ne.phii1) phii1=150.0
4824           phii1=pinorm(phii1)
4825 #else
4826           phii1=phi(i+1)
4827 #endif
4828           ityp3=ithetyp((itype(i)))
4829           do k=1,nsingle
4830             cosph2(k)=dcos(k*phii1)
4831             sinph2(k)=dsin(k*phii1)
4832           enddo
4833         else
4834           phii1=0.0d0
4835           ityp3=nthetyp+1
4836           do k=1,nsingle
4837             cosph2(k)=0.0d0
4838             sinph2(k)=0.0d0
4839           enddo
4840         endif
4841         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4842         do k=1,ndouble
4843           do l=1,k-1
4844             ccl=cosph1(l)*cosph2(k-l)
4845             ssl=sinph1(l)*sinph2(k-l)
4846             scl=sinph1(l)*cosph2(k-l)
4847             csl=cosph1(l)*sinph2(k-l)
4848             cosph1ph2(l,k)=ccl-ssl
4849             cosph1ph2(k,l)=ccl+ssl
4850             sinph1ph2(l,k)=scl+csl
4851             sinph1ph2(k,l)=scl-csl
4852           enddo
4853         enddo
4854         if (lprn) then
4855         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4856      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4857         write (iout,*) "coskt and sinkt"
4858         do k=1,nntheterm
4859           write (iout,*) k,coskt(k),sinkt(k)
4860         enddo
4861         endif
4862         do k=1,ntheterm
4863           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4864           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4865      &      *coskt(k)
4866           if (lprn)
4867      &    write (iout,*) "k",k,"
4868      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4869      &     " ethetai",ethetai
4870         enddo
4871         if (lprn) then
4872         write (iout,*) "cosph and sinph"
4873         do k=1,nsingle
4874           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4875         enddo
4876         write (iout,*) "cosph1ph2 and sinph2ph2"
4877         do k=2,ndouble
4878           do l=1,k-1
4879             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4880      &         sinph1ph2(l,k),sinph1ph2(k,l)
4881           enddo
4882         enddo
4883         write(iout,*) "ethetai",ethetai
4884         endif
4885         do m=1,ntheterm2
4886           do k=1,nsingle
4887             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4888      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4889      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4890      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4891             ethetai=ethetai+sinkt(m)*aux
4892             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4893             dephii=dephii+k*sinkt(m)*(
4894      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4895      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4896             dephii1=dephii1+k*sinkt(m)*(
4897      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4898      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4899             if (lprn)
4900      &      write (iout,*) "m",m," k",k," bbthet",
4901      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4902      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4903      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4904      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4905           enddo
4906         enddo
4907         if (lprn)
4908      &  write(iout,*) "ethetai",ethetai
4909         do m=1,ntheterm3
4910           do k=2,ndouble
4911             do l=1,k-1
4912               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4913      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4914      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4915      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4916               ethetai=ethetai+sinkt(m)*aux
4917               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4918               dephii=dephii+l*sinkt(m)*(
4919      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4920      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4921      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4922      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4923               dephii1=dephii1+(k-l)*sinkt(m)*(
4924      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4925      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4926      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4927      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4928               if (lprn) then
4929               write (iout,*) "m",m," k",k," l",l," ffthet",
4930      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4931      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4932      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4933      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4934      &            " ethetai",ethetai
4935               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4936      &            cosph1ph2(k,l)*sinkt(m),
4937      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4938               endif
4939             enddo
4940           enddo
4941         enddo
4942 10      continue
4943 c        lprn1=.true.
4944         if (lprn1)
4945      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4946      &   i,theta(i)*rad2deg,phii*rad2deg,
4947      &   phii1*rad2deg,ethetai
4948 c        lprn1=.false.
4949         etheta=etheta+ethetai
4950         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4951         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4952         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4953       enddo
4954       return
4955       end
4956 #endif
4957 #ifdef CRYST_SC
4958 c-----------------------------------------------------------------------------
4959       subroutine esc(escloc)
4960 C Calculate the local energy of a side chain and its derivatives in the
4961 C corresponding virtual-bond valence angles THETA and the spherical angles
4962 C ALPHA and OMEGA.
4963       implicit real*8 (a-h,o-z)
4964       include 'DIMENSIONS'
4965       include 'COMMON.GEO'
4966       include 'COMMON.LOCAL'
4967       include 'COMMON.VAR'
4968       include 'COMMON.INTERACT'
4969       include 'COMMON.DERIV'
4970       include 'COMMON.CHAIN'
4971       include 'COMMON.IOUNITS'
4972       include 'COMMON.NAMES'
4973       include 'COMMON.FFIELD'
4974       include 'COMMON.CONTROL'
4975       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4976      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4977       common /sccalc/ time11,time12,time112,theti,it,nlobit
4978       delta=0.02d0*pi
4979       escloc=0.0D0
4980 c     write (iout,'(a)') 'ESC'
4981       do i=loc_start,loc_end
4982         it=itype(i)
4983         if (it.eq.ntyp1) cycle
4984         if (it.eq.10) goto 1
4985         nlobit=nlob(iabs(it))
4986 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4987 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4988         theti=theta(i+1)-pipol
4989         x(1)=dtan(theti)
4990         x(2)=alph(i)
4991         x(3)=omeg(i)
4992
4993         if (x(2).gt.pi-delta) then
4994           xtemp(1)=x(1)
4995           xtemp(2)=pi-delta
4996           xtemp(3)=x(3)
4997           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4998           xtemp(2)=pi
4999           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5000           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5001      &        escloci,dersc(2))
5002           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5003      &        ddersc0(1),dersc(1))
5004           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5005      &        ddersc0(3),dersc(3))
5006           xtemp(2)=pi-delta
5007           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5008           xtemp(2)=pi
5009           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5010           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5011      &            dersc0(2),esclocbi,dersc02)
5012           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5013      &            dersc12,dersc01)
5014           call splinthet(x(2),0.5d0*delta,ss,ssd)
5015           dersc0(1)=dersc01
5016           dersc0(2)=dersc02
5017           dersc0(3)=0.0d0
5018           do k=1,3
5019             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5020           enddo
5021           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5022 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5023 c    &             esclocbi,ss,ssd
5024           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5025 c         escloci=esclocbi
5026 c         write (iout,*) escloci
5027         else if (x(2).lt.delta) then
5028           xtemp(1)=x(1)
5029           xtemp(2)=delta
5030           xtemp(3)=x(3)
5031           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5032           xtemp(2)=0.0d0
5033           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5034           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5035      &        escloci,dersc(2))
5036           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5037      &        ddersc0(1),dersc(1))
5038           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5039      &        ddersc0(3),dersc(3))
5040           xtemp(2)=delta
5041           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5042           xtemp(2)=0.0d0
5043           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5044           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5045      &            dersc0(2),esclocbi,dersc02)
5046           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5047      &            dersc12,dersc01)
5048           dersc0(1)=dersc01
5049           dersc0(2)=dersc02
5050           dersc0(3)=0.0d0
5051           call splinthet(x(2),0.5d0*delta,ss,ssd)
5052           do k=1,3
5053             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5054           enddo
5055           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5056 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5057 c    &             esclocbi,ss,ssd
5058           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5059 c         write (iout,*) escloci
5060         else
5061           call enesc(x,escloci,dersc,ddummy,.false.)
5062         endif
5063
5064         escloc=escloc+escloci
5065         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5066      &     'escloc',i,escloci
5067 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5068
5069         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5070      &   wscloc*dersc(1)
5071         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5072         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5073     1   continue
5074       enddo
5075       return
5076       end
5077 C---------------------------------------------------------------------------
5078       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5079       implicit real*8 (a-h,o-z)
5080       include 'DIMENSIONS'
5081       include 'COMMON.GEO'
5082       include 'COMMON.LOCAL'
5083       include 'COMMON.IOUNITS'
5084       common /sccalc/ time11,time12,time112,theti,it,nlobit
5085       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5086       double precision contr(maxlob,-1:1)
5087       logical mixed
5088 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5089         escloc_i=0.0D0
5090         do j=1,3
5091           dersc(j)=0.0D0
5092           if (mixed) ddersc(j)=0.0d0
5093         enddo
5094         x3=x(3)
5095
5096 C Because of periodicity of the dependence of the SC energy in omega we have
5097 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5098 C To avoid underflows, first compute & store the exponents.
5099
5100         do iii=-1,1
5101
5102           x(3)=x3+iii*dwapi
5103
5104           do j=1,nlobit
5105             do k=1,3
5106               z(k)=x(k)-censc(k,j,it)
5107             enddo
5108             do k=1,3
5109               Axk=0.0D0
5110               do l=1,3
5111                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5112               enddo
5113               Ax(k,j,iii)=Axk
5114             enddo
5115             expfac=0.0D0
5116             do k=1,3
5117               expfac=expfac+Ax(k,j,iii)*z(k)
5118             enddo
5119             contr(j,iii)=expfac
5120           enddo ! j
5121
5122         enddo ! iii
5123
5124         x(3)=x3
5125 C As in the case of ebend, we want to avoid underflows in exponentiation and
5126 C subsequent NaNs and INFs in energy calculation.
5127 C Find the largest exponent
5128         emin=contr(1,-1)
5129         do iii=-1,1
5130           do j=1,nlobit
5131             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5132           enddo
5133         enddo
5134         emin=0.5D0*emin
5135 cd      print *,'it=',it,' emin=',emin
5136
5137 C Compute the contribution to SC energy and derivatives
5138         do iii=-1,1
5139
5140           do j=1,nlobit
5141 #ifdef OSF
5142             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5143             if(adexp.ne.adexp) adexp=1.0
5144             expfac=dexp(adexp)
5145 #else
5146             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5147 #endif
5148 cd          print *,'j=',j,' expfac=',expfac
5149             escloc_i=escloc_i+expfac
5150             do k=1,3
5151               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5152             enddo
5153             if (mixed) then
5154               do k=1,3,2
5155                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5156      &            +gaussc(k,2,j,it))*expfac
5157               enddo
5158             endif
5159           enddo
5160
5161         enddo ! iii
5162
5163         dersc(1)=dersc(1)/cos(theti)**2
5164         ddersc(1)=ddersc(1)/cos(theti)**2
5165         ddersc(3)=ddersc(3)
5166
5167         escloci=-(dlog(escloc_i)-emin)
5168         do j=1,3
5169           dersc(j)=dersc(j)/escloc_i
5170         enddo
5171         if (mixed) then
5172           do j=1,3,2
5173             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5174           enddo
5175         endif
5176       return
5177       end
5178 C------------------------------------------------------------------------------
5179       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5180       implicit real*8 (a-h,o-z)
5181       include 'DIMENSIONS'
5182       include 'COMMON.GEO'
5183       include 'COMMON.LOCAL'
5184       include 'COMMON.IOUNITS'
5185       common /sccalc/ time11,time12,time112,theti,it,nlobit
5186       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5187       double precision contr(maxlob)
5188       logical mixed
5189
5190       escloc_i=0.0D0
5191
5192       do j=1,3
5193         dersc(j)=0.0D0
5194       enddo
5195
5196       do j=1,nlobit
5197         do k=1,2
5198           z(k)=x(k)-censc(k,j,it)
5199         enddo
5200         z(3)=dwapi
5201         do k=1,3
5202           Axk=0.0D0
5203           do l=1,3
5204             Axk=Axk+gaussc(l,k,j,it)*z(l)
5205           enddo
5206           Ax(k,j)=Axk
5207         enddo
5208         expfac=0.0D0
5209         do k=1,3
5210           expfac=expfac+Ax(k,j)*z(k)
5211         enddo
5212         contr(j)=expfac
5213       enddo ! j
5214
5215 C As in the case of ebend, we want to avoid underflows in exponentiation and
5216 C subsequent NaNs and INFs in energy calculation.
5217 C Find the largest exponent
5218       emin=contr(1)
5219       do j=1,nlobit
5220         if (emin.gt.contr(j)) emin=contr(j)
5221       enddo
5222       emin=0.5D0*emin
5223
5224 C Compute the contribution to SC energy and derivatives
5225
5226       dersc12=0.0d0
5227       do j=1,nlobit
5228         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5229         escloc_i=escloc_i+expfac
5230         do k=1,2
5231           dersc(k)=dersc(k)+Ax(k,j)*expfac
5232         enddo
5233         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5234      &            +gaussc(1,2,j,it))*expfac
5235         dersc(3)=0.0d0
5236       enddo
5237
5238       dersc(1)=dersc(1)/cos(theti)**2
5239       dersc12=dersc12/cos(theti)**2
5240       escloci=-(dlog(escloc_i)-emin)
5241       do j=1,2
5242         dersc(j)=dersc(j)/escloc_i
5243       enddo
5244       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5245       return
5246       end
5247 #else
5248 c----------------------------------------------------------------------------------
5249       subroutine esc(escloc)
5250 C Calculate the local energy of a side chain and its derivatives in the
5251 C corresponding virtual-bond valence angles THETA and the spherical angles
5252 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5253 C added by Urszula Kozlowska. 07/11/2007
5254 C
5255       implicit real*8 (a-h,o-z)
5256       include 'DIMENSIONS'
5257       include 'COMMON.GEO'
5258       include 'COMMON.LOCAL'
5259       include 'COMMON.VAR'
5260       include 'COMMON.SCROT'
5261       include 'COMMON.INTERACT'
5262       include 'COMMON.DERIV'
5263       include 'COMMON.CHAIN'
5264       include 'COMMON.IOUNITS'
5265       include 'COMMON.NAMES'
5266       include 'COMMON.FFIELD'
5267       include 'COMMON.CONTROL'
5268       include 'COMMON.VECTORS'
5269       double precision x_prime(3),y_prime(3),z_prime(3)
5270      &    , sumene,dsc_i,dp2_i,x(65),
5271      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5272      &    de_dxx,de_dyy,de_dzz,de_dt
5273       double precision s1_t,s1_6_t,s2_t,s2_6_t
5274       double precision
5275      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5276      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5277      & dt_dCi(3),dt_dCi1(3)
5278       common /sccalc/ time11,time12,time112,theti,it,nlobit
5279       delta=0.02d0*pi
5280       escloc=0.0D0
5281       do i=loc_start,loc_end
5282         if (itype(i).eq.ntyp1) cycle
5283         costtab(i+1) =dcos(theta(i+1))
5284         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5285         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5286         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5287         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5288         cosfac=dsqrt(cosfac2)
5289         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5290         sinfac=dsqrt(sinfac2)
5291         it=iabs(itype(i))
5292         if (it.eq.10) goto 1
5293 c
5294 C  Compute the axes of tghe local cartesian coordinates system; store in
5295 c   x_prime, y_prime and z_prime
5296 c
5297         do j=1,3
5298           x_prime(j) = 0.00
5299           y_prime(j) = 0.00
5300           z_prime(j) = 0.00
5301         enddo
5302 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5303 C     &   dc_norm(3,i+nres)
5304         do j = 1,3
5305           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5306           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5307         enddo
5308         do j = 1,3
5309           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5310         enddo
5311 c       write (2,*) "i",i
5312 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5313 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5314 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5315 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5316 c      & " xy",scalar(x_prime(1),y_prime(1)),
5317 c      & " xz",scalar(x_prime(1),z_prime(1)),
5318 c      & " yy",scalar(y_prime(1),y_prime(1)),
5319 c      & " yz",scalar(y_prime(1),z_prime(1)),
5320 c      & " zz",scalar(z_prime(1),z_prime(1))
5321 c
5322 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5323 C to local coordinate system. Store in xx, yy, zz.
5324 c
5325         xx=0.0d0
5326         yy=0.0d0
5327         zz=0.0d0
5328         do j = 1,3
5329           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5330           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5331           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5332         enddo
5333
5334         xxtab(i)=xx
5335         yytab(i)=yy
5336         zztab(i)=zz
5337 C
5338 C Compute the energy of the ith side cbain
5339 C
5340 c        write (2,*) "xx",xx," yy",yy," zz",zz
5341         it=iabs(itype(i))
5342         do j = 1,65
5343           x(j) = sc_parmin(j,it)
5344         enddo
5345 #ifdef CHECK_COORD
5346 Cc diagnostics - remove later
5347         xx1 = dcos(alph(2))
5348         yy1 = dsin(alph(2))*dcos(omeg(2))
5349         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5350         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5351      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5352      &    xx1,yy1,zz1
5353 C,"  --- ", xx_w,yy_w,zz_w
5354 c end diagnostics
5355 #endif
5356         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5357      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5358      &   + x(10)*yy*zz
5359         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5360      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5361      & + x(20)*yy*zz
5362         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5363      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5364      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5365      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5366      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5367      &  +x(40)*xx*yy*zz
5368         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5369      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5370      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5371      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5372      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5373      &  +x(60)*xx*yy*zz
5374         dsc_i   = 0.743d0+x(61)
5375         dp2_i   = 1.9d0+x(62)
5376         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5377      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5378         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5379      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5380         s1=(1+x(63))/(0.1d0 + dscp1)
5381         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5382         s2=(1+x(65))/(0.1d0 + dscp2)
5383         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5384         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5385      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5386 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5387 c     &   sumene4,
5388 c     &   dscp1,dscp2,sumene
5389 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5390         escloc = escloc + sumene
5391 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5392 c     & ,zz,xx,yy
5393 c#define DEBUG
5394 #ifdef DEBUG
5395 C
5396 C This section to check the numerical derivatives of the energy of ith side
5397 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5398 C #define DEBUG in the code to turn it on.
5399 C
5400         write (2,*) "sumene               =",sumene
5401         aincr=1.0d-7
5402         xxsave=xx
5403         xx=xx+aincr
5404         write (2,*) xx,yy,zz
5405         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5406         de_dxx_num=(sumenep-sumene)/aincr
5407         xx=xxsave
5408         write (2,*) "xx+ sumene from enesc=",sumenep
5409         yysave=yy
5410         yy=yy+aincr
5411         write (2,*) xx,yy,zz
5412         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5413         de_dyy_num=(sumenep-sumene)/aincr
5414         yy=yysave
5415         write (2,*) "yy+ sumene from enesc=",sumenep
5416         zzsave=zz
5417         zz=zz+aincr
5418         write (2,*) xx,yy,zz
5419         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5420         de_dzz_num=(sumenep-sumene)/aincr
5421         zz=zzsave
5422         write (2,*) "zz+ sumene from enesc=",sumenep
5423         costsave=cost2tab(i+1)
5424         sintsave=sint2tab(i+1)
5425         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5426         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5427         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5428         de_dt_num=(sumenep-sumene)/aincr
5429         write (2,*) " t+ sumene from enesc=",sumenep
5430         cost2tab(i+1)=costsave
5431         sint2tab(i+1)=sintsave
5432 C End of diagnostics section.
5433 #endif
5434 C
5435 C Compute the gradient of esc
5436 C
5437 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5438         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5439         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5440         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5441         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5442         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5443         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5444         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5445         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5446         pom1=(sumene3*sint2tab(i+1)+sumene1)
5447      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5448         pom2=(sumene4*cost2tab(i+1)+sumene2)
5449      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5450         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5451         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5452      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5453      &  +x(40)*yy*zz
5454         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5455         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5456      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5457      &  +x(60)*yy*zz
5458         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5459      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5460      &        +(pom1+pom2)*pom_dx
5461 #ifdef DEBUG
5462         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5463 #endif
5464 C
5465         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5466         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5467      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5468      &  +x(40)*xx*zz
5469         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5470         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5471      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5472      &  +x(59)*zz**2 +x(60)*xx*zz
5473         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5474      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5475      &        +(pom1-pom2)*pom_dy
5476 #ifdef DEBUG
5477         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5478 #endif
5479 C
5480         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5481      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5482      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5483      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5484      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5485      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5486      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5487      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5488 #ifdef DEBUG
5489         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5490 #endif
5491 C
5492         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5493      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5494      &  +pom1*pom_dt1+pom2*pom_dt2
5495 #ifdef DEBUG
5496         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5497 #endif
5498 c#undef DEBUG
5499 c
5500 C
5501        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5502        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5503        cosfac2xx=cosfac2*xx
5504        sinfac2yy=sinfac2*yy
5505        do k = 1,3
5506          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5507      &      vbld_inv(i+1)
5508          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5509      &      vbld_inv(i)
5510          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5511          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5512 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5513 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5514 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5515 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5516          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5517          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5518          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5519          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5520          dZZ_Ci1(k)=0.0d0
5521          dZZ_Ci(k)=0.0d0
5522          do j=1,3
5523            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5524      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5525            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5526      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5527          enddo
5528
5529          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5530          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5531          dZZ_XYZ(k)=vbld_inv(i+nres)*
5532      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5533 c
5534          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5535          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5536        enddo
5537
5538        do k=1,3
5539          dXX_Ctab(k,i)=dXX_Ci(k)
5540          dXX_C1tab(k,i)=dXX_Ci1(k)
5541          dYY_Ctab(k,i)=dYY_Ci(k)
5542          dYY_C1tab(k,i)=dYY_Ci1(k)
5543          dZZ_Ctab(k,i)=dZZ_Ci(k)
5544          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5545          dXX_XYZtab(k,i)=dXX_XYZ(k)
5546          dYY_XYZtab(k,i)=dYY_XYZ(k)
5547          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5548        enddo
5549
5550        do k = 1,3
5551 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5552 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5553 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5554 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5555 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5556 c     &    dt_dci(k)
5557 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5558 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5559          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5560      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5561          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5562      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5563          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5564      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5565        enddo
5566 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5567 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5568
5569 C to check gradient call subroutine check_grad
5570
5571     1 continue
5572       enddo
5573       return
5574       end
5575 c------------------------------------------------------------------------------
5576       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5577       implicit none
5578       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5579      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5580       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5581      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5582      &   + x(10)*yy*zz
5583       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5584      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5585      & + x(20)*yy*zz
5586       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5587      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5588      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5589      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5590      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5591      &  +x(40)*xx*yy*zz
5592       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5593      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5594      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5595      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5596      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5597      &  +x(60)*xx*yy*zz
5598       dsc_i   = 0.743d0+x(61)
5599       dp2_i   = 1.9d0+x(62)
5600       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5601      &          *(xx*cost2+yy*sint2))
5602       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5603      &          *(xx*cost2-yy*sint2))
5604       s1=(1+x(63))/(0.1d0 + dscp1)
5605       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5606       s2=(1+x(65))/(0.1d0 + dscp2)
5607       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5608       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5609      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5610       enesc=sumene
5611       return
5612       end
5613 #endif
5614 c------------------------------------------------------------------------------
5615       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5616 C
5617 C This procedure calculates two-body contact function g(rij) and its derivative:
5618 C
5619 C           eps0ij                                     !       x < -1
5620 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5621 C            0                                         !       x > 1
5622 C
5623 C where x=(rij-r0ij)/delta
5624 C
5625 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5626 C
5627       implicit none
5628       double precision rij,r0ij,eps0ij,fcont,fprimcont
5629       double precision x,x2,x4,delta
5630 c     delta=0.02D0*r0ij
5631 c      delta=0.2D0*r0ij
5632       x=(rij-r0ij)/delta
5633       if (x.lt.-1.0D0) then
5634         fcont=eps0ij
5635         fprimcont=0.0D0
5636       else if (x.le.1.0D0) then
5637         x2=x*x
5638         x4=x2*x2
5639         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5640         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5641       else
5642         fcont=0.0D0
5643         fprimcont=0.0D0
5644       endif
5645       return
5646       end
5647 c------------------------------------------------------------------------------
5648       subroutine splinthet(theti,delta,ss,ssder)
5649       implicit real*8 (a-h,o-z)
5650       include 'DIMENSIONS'
5651       include 'COMMON.VAR'
5652       include 'COMMON.GEO'
5653       thetup=pi-delta
5654       thetlow=delta
5655       if (theti.gt.pipol) then
5656         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5657       else
5658         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5659         ssder=-ssder
5660       endif
5661       return
5662       end
5663 c------------------------------------------------------------------------------
5664       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5665       implicit none
5666       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5667       double precision ksi,ksi2,ksi3,a1,a2,a3
5668       a1=fprim0*delta/(f1-f0)
5669       a2=3.0d0-2.0d0*a1
5670       a3=a1-2.0d0
5671       ksi=(x-x0)/delta
5672       ksi2=ksi*ksi
5673       ksi3=ksi2*ksi
5674       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5675       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5676       return
5677       end
5678 c------------------------------------------------------------------------------
5679       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5680       implicit none
5681       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5682       double precision ksi,ksi2,ksi3,a1,a2,a3
5683       ksi=(x-x0)/delta
5684       ksi2=ksi*ksi
5685       ksi3=ksi2*ksi
5686       a1=fprim0x*delta
5687       a2=3*(f1x-f0x)-2*fprim0x*delta
5688       a3=fprim0x*delta-2*(f1x-f0x)
5689       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5690       return
5691       end
5692 C-----------------------------------------------------------------------------
5693 #ifdef CRYST_TOR
5694 C-----------------------------------------------------------------------------
5695       subroutine etor(etors,edihcnstr)
5696       implicit real*8 (a-h,o-z)
5697       include 'DIMENSIONS'
5698       include 'COMMON.VAR'
5699       include 'COMMON.GEO'
5700       include 'COMMON.LOCAL'
5701       include 'COMMON.TORSION'
5702       include 'COMMON.INTERACT'
5703       include 'COMMON.DERIV'
5704       include 'COMMON.CHAIN'
5705       include 'COMMON.NAMES'
5706       include 'COMMON.IOUNITS'
5707       include 'COMMON.FFIELD'
5708       include 'COMMON.TORCNSTR'
5709       include 'COMMON.CONTROL'
5710       logical lprn
5711 C Set lprn=.true. for debugging
5712       lprn=.false.
5713 c      lprn=.true.
5714       etors=0.0D0
5715       do i=iphi_start,iphi_end
5716       etors_ii=0.0D0
5717         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5718      &      .or. itype(i).eq.ntyp1) cycle
5719         itori=itortyp(itype(i-2))
5720         itori1=itortyp(itype(i-1))
5721         phii=phi(i)
5722         gloci=0.0D0
5723 C Proline-Proline pair is a special case...
5724         if (itori.eq.3 .and. itori1.eq.3) then
5725           if (phii.gt.-dwapi3) then
5726             cosphi=dcos(3*phii)
5727             fac=1.0D0/(1.0D0-cosphi)
5728             etorsi=v1(1,3,3)*fac
5729             etorsi=etorsi+etorsi
5730             etors=etors+etorsi-v1(1,3,3)
5731             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5732             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5733           endif
5734           do j=1,3
5735             v1ij=v1(j+1,itori,itori1)
5736             v2ij=v2(j+1,itori,itori1)
5737             cosphi=dcos(j*phii)
5738             sinphi=dsin(j*phii)
5739             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5740             if (energy_dec) etors_ii=etors_ii+
5741      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5742             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5743           enddo
5744         else
5745           do j=1,nterm_old
5746             v1ij=v1(j,itori,itori1)
5747             v2ij=v2(j,itori,itori1)
5748             cosphi=dcos(j*phii)
5749             sinphi=dsin(j*phii)
5750             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5751             if (energy_dec) etors_ii=etors_ii+
5752      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5753             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5754           enddo
5755         endif
5756         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5757              'etor',i,etors_ii
5758         if (lprn)
5759      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5760      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5761      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5762         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5763 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5764       enddo
5765 ! 6/20/98 - dihedral angle constraints
5766       edihcnstr=0.0d0
5767       do i=1,ndih_constr
5768         itori=idih_constr(i)
5769         phii=phi(itori)
5770         difi=phii-phi0(i)
5771         if (difi.gt.drange(i)) then
5772           difi=difi-drange(i)
5773           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5774           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5775         else if (difi.lt.-drange(i)) then
5776           difi=difi+drange(i)
5777           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5778           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5779         endif
5780 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5781 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5782       enddo
5783 !      write (iout,*) 'edihcnstr',edihcnstr
5784       return
5785       end
5786 c------------------------------------------------------------------------------
5787       subroutine etor_d(etors_d)
5788       etors_d=0.0d0
5789       return
5790       end
5791 c----------------------------------------------------------------------------
5792 #else
5793       subroutine etor(etors,edihcnstr)
5794       implicit real*8 (a-h,o-z)
5795       include 'DIMENSIONS'
5796       include 'COMMON.VAR'
5797       include 'COMMON.GEO'
5798       include 'COMMON.LOCAL'
5799       include 'COMMON.TORSION'
5800       include 'COMMON.INTERACT'
5801       include 'COMMON.DERIV'
5802       include 'COMMON.CHAIN'
5803       include 'COMMON.NAMES'
5804       include 'COMMON.IOUNITS'
5805       include 'COMMON.FFIELD'
5806       include 'COMMON.TORCNSTR'
5807       include 'COMMON.CONTROL'
5808       logical lprn
5809 C Set lprn=.true. for debugging
5810       lprn=.false.
5811 c     lprn=.true.
5812       etors=0.0D0
5813       do i=iphi_start,iphi_end
5814         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5815      &       .or. itype(i).eq.ntyp1) cycle
5816         etors_ii=0.0D0
5817          if (iabs(itype(i)).eq.20) then
5818          iblock=2
5819          else
5820          iblock=1
5821          endif
5822         itori=itortyp(itype(i-2))
5823         itori1=itortyp(itype(i-1))
5824         phii=phi(i)
5825         gloci=0.0D0
5826 C Regular cosine and sine terms
5827         do j=1,nterm(itori,itori1,iblock)
5828           v1ij=v1(j,itori,itori1,iblock)
5829           v2ij=v2(j,itori,itori1,iblock)
5830           cosphi=dcos(j*phii)
5831           sinphi=dsin(j*phii)
5832           etors=etors+v1ij*cosphi+v2ij*sinphi
5833           if (energy_dec) etors_ii=etors_ii+
5834      &                v1ij*cosphi+v2ij*sinphi
5835           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5836         enddo
5837 C Lorentz terms
5838 C                         v1
5839 C  E = SUM ----------------------------------- - v1
5840 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5841 C
5842         cosphi=dcos(0.5d0*phii)
5843         sinphi=dsin(0.5d0*phii)
5844         do j=1,nlor(itori,itori1,iblock)
5845           vl1ij=vlor1(j,itori,itori1)
5846           vl2ij=vlor2(j,itori,itori1)
5847           vl3ij=vlor3(j,itori,itori1)
5848           pom=vl2ij*cosphi+vl3ij*sinphi
5849           pom1=1.0d0/(pom*pom+1.0d0)
5850           etors=etors+vl1ij*pom1
5851           if (energy_dec) etors_ii=etors_ii+
5852      &                vl1ij*pom1
5853           pom=-pom*pom1*pom1
5854           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5855         enddo
5856 C Subtract the constant term
5857         etors=etors-v0(itori,itori1,iblock)
5858           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5859      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5860         if (lprn)
5861      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5862      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5863      &  (v1(j,itori,itori1,iblock),j=1,6),
5864      &  (v2(j,itori,itori1,iblock),j=1,6)
5865         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5866 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5867       enddo
5868 ! 6/20/98 - dihedral angle constraints
5869       edihcnstr=0.0d0
5870 c      do i=1,ndih_constr
5871       do i=idihconstr_start,idihconstr_end
5872         itori=idih_constr(i)
5873         phii=phi(itori)
5874         difi=pinorm(phii-phi0(i))
5875         if (difi.gt.drange(i)) then
5876           difi=difi-drange(i)
5877           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5878           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5879         else if (difi.lt.-drange(i)) then
5880           difi=difi+drange(i)
5881           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5882           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5883         else
5884           difi=0.0
5885         endif
5886 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5887 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5888 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5889       enddo
5890 cd       write (iout,*) 'edihcnstr',edihcnstr
5891       return
5892       end
5893 c----------------------------------------------------------------------------
5894       subroutine etor_d(etors_d)
5895 C 6/23/01 Compute double torsional energy
5896       implicit real*8 (a-h,o-z)
5897       include 'DIMENSIONS'
5898       include 'COMMON.VAR'
5899       include 'COMMON.GEO'
5900       include 'COMMON.LOCAL'
5901       include 'COMMON.TORSION'
5902       include 'COMMON.INTERACT'
5903       include 'COMMON.DERIV'
5904       include 'COMMON.CHAIN'
5905       include 'COMMON.NAMES'
5906       include 'COMMON.IOUNITS'
5907       include 'COMMON.FFIELD'
5908       include 'COMMON.TORCNSTR'
5909       logical lprn
5910 C Set lprn=.true. for debugging
5911       lprn=.false.
5912 c     lprn=.true.
5913       etors_d=0.0D0
5914 c      write(iout,*) "a tu??"
5915       do i=iphid_start,iphid_end
5916         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5917      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5918         itori=itortyp(itype(i-2))
5919         itori1=itortyp(itype(i-1))
5920         itori2=itortyp(itype(i))
5921         phii=phi(i)
5922         phii1=phi(i+1)
5923         gloci1=0.0D0
5924         gloci2=0.0D0
5925         iblock=1
5926         if (iabs(itype(i+1)).eq.20) iblock=2
5927
5928 C Regular cosine and sine terms
5929         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5930           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5931           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5932           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5933           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5934           cosphi1=dcos(j*phii)
5935           sinphi1=dsin(j*phii)
5936           cosphi2=dcos(j*phii1)
5937           sinphi2=dsin(j*phii1)
5938           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5939      &     v2cij*cosphi2+v2sij*sinphi2
5940           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5941           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5942         enddo
5943         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5944           do l=1,k-1
5945             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5946             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5947             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5948             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5949             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5950             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5951             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5952             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5953             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5954      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5955             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5956      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5957             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5958      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5959           enddo
5960         enddo
5961         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5962         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5963       enddo
5964       return
5965       end
5966 #endif
5967 c------------------------------------------------------------------------------
5968       subroutine eback_sc_corr(esccor)
5969 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5970 c        conformational states; temporarily implemented as differences
5971 c        between UNRES torsional potentials (dependent on three types of
5972 c        residues) and the torsional potentials dependent on all 20 types
5973 c        of residues computed from AM1  energy surfaces of terminally-blocked
5974 c        amino-acid residues.
5975       implicit real*8 (a-h,o-z)
5976       include 'DIMENSIONS'
5977       include 'COMMON.VAR'
5978       include 'COMMON.GEO'
5979       include 'COMMON.LOCAL'
5980       include 'COMMON.TORSION'
5981       include 'COMMON.SCCOR'
5982       include 'COMMON.INTERACT'
5983       include 'COMMON.DERIV'
5984       include 'COMMON.CHAIN'
5985       include 'COMMON.NAMES'
5986       include 'COMMON.IOUNITS'
5987       include 'COMMON.FFIELD'
5988       include 'COMMON.CONTROL'
5989       logical lprn
5990 C Set lprn=.true. for debugging
5991       lprn=.false.
5992 c      lprn=.true.
5993 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5994       esccor=0.0D0
5995       do i=itau_start,itau_end
5996         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5997         esccor_ii=0.0D0
5998         isccori=isccortyp(itype(i-2))
5999         isccori1=isccortyp(itype(i-1))
6000 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6001         phii=phi(i)
6002         do intertyp=1,3 !intertyp
6003 cc Added 09 May 2012 (Adasko)
6004 cc  Intertyp means interaction type of backbone mainchain correlation:
6005 c   1 = SC...Ca...Ca...Ca
6006 c   2 = Ca...Ca...Ca...SC
6007 c   3 = SC...Ca...Ca...SCi
6008         gloci=0.0D0
6009         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6010      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6011      &      (itype(i-1).eq.ntyp1)))
6012      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6013      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6014      &     .or.(itype(i).eq.ntyp1)))
6015      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6016      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6017      &      (itype(i-3).eq.ntyp1)))) cycle
6018         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6019         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6020      & cycle
6021        do j=1,nterm_sccor(isccori,isccori1)
6022           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6023           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6024           cosphi=dcos(j*tauangle(intertyp,i))
6025           sinphi=dsin(j*tauangle(intertyp,i))
6026           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6027           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6028         enddo
6029 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6030         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6031         if (lprn)
6032      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6033      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6034      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6035      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6036         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6037        enddo !intertyp
6038       enddo
6039
6040       return
6041       end
6042 c----------------------------------------------------------------------------
6043       subroutine multibody(ecorr)
6044 C This subroutine calculates multi-body contributions to energy following
6045 C the idea of Skolnick et al. If side chains I and J make a contact and
6046 C at the same time side chains I+1 and J+1 make a contact, an extra
6047 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6048       implicit real*8 (a-h,o-z)
6049       include 'DIMENSIONS'
6050       include 'COMMON.IOUNITS'
6051       include 'COMMON.DERIV'
6052       include 'COMMON.INTERACT'
6053       include 'COMMON.CONTACTS'
6054       double precision gx(3),gx1(3)
6055       logical lprn
6056
6057 C Set lprn=.true. for debugging
6058       lprn=.false.
6059
6060       if (lprn) then
6061         write (iout,'(a)') 'Contact function values:'
6062         do i=nnt,nct-2
6063           write (iout,'(i2,20(1x,i2,f10.5))')
6064      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6065         enddo
6066       endif
6067       ecorr=0.0D0
6068       do i=nnt,nct
6069         do j=1,3
6070           gradcorr(j,i)=0.0D0
6071           gradxorr(j,i)=0.0D0
6072         enddo
6073       enddo
6074       do i=nnt,nct-2
6075
6076         DO ISHIFT = 3,4
6077
6078         i1=i+ishift
6079         num_conti=num_cont(i)
6080         num_conti1=num_cont(i1)
6081         do jj=1,num_conti
6082           j=jcont(jj,i)
6083           do kk=1,num_conti1
6084             j1=jcont(kk,i1)
6085             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6086 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6087 cd   &                   ' ishift=',ishift
6088 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6089 C The system gains extra energy.
6090               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6091             endif   ! j1==j+-ishift
6092           enddo     ! kk
6093         enddo       ! jj
6094
6095         ENDDO ! ISHIFT
6096
6097       enddo         ! i
6098       return
6099       end
6100 c------------------------------------------------------------------------------
6101       double precision function esccorr(i,j,k,l,jj,kk)
6102       implicit real*8 (a-h,o-z)
6103       include 'DIMENSIONS'
6104       include 'COMMON.IOUNITS'
6105       include 'COMMON.DERIV'
6106       include 'COMMON.INTERACT'
6107       include 'COMMON.CONTACTS'
6108       double precision gx(3),gx1(3)
6109       logical lprn
6110       lprn=.false.
6111       eij=facont(jj,i)
6112       ekl=facont(kk,k)
6113 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6114 C Calculate the multi-body contribution to energy.
6115 C Calculate multi-body contributions to the gradient.
6116 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6117 cd   & k,l,(gacont(m,kk,k),m=1,3)
6118       do m=1,3
6119         gx(m) =ekl*gacont(m,jj,i)
6120         gx1(m)=eij*gacont(m,kk,k)
6121         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6122         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6123         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6124         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6125       enddo
6126       do m=i,j-1
6127         do ll=1,3
6128           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6129         enddo
6130       enddo
6131       do m=k,l-1
6132         do ll=1,3
6133           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6134         enddo
6135       enddo
6136       esccorr=-eij*ekl
6137       return
6138       end
6139 c------------------------------------------------------------------------------
6140       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6141 C This subroutine calculates multi-body contributions to hydrogen-bonding
6142       implicit real*8 (a-h,o-z)
6143       include 'DIMENSIONS'
6144       include 'COMMON.IOUNITS'
6145 #ifdef MPI
6146       include "mpif.h"
6147       parameter (max_cont=maxconts)
6148       parameter (max_dim=26)
6149       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6150       double precision zapas(max_dim,maxconts,max_fg_procs),
6151      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6152       common /przechowalnia/ zapas
6153       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6154      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6155 #endif
6156       include 'COMMON.SETUP'
6157       include 'COMMON.FFIELD'
6158       include 'COMMON.DERIV'
6159       include 'COMMON.INTERACT'
6160       include 'COMMON.CONTACTS'
6161       include 'COMMON.CONTROL'
6162       include 'COMMON.LOCAL'
6163       double precision gx(3),gx1(3),time00
6164       logical lprn,ldone
6165
6166 C Set lprn=.true. for debugging
6167       lprn=.false.
6168 #ifdef MPI
6169       n_corr=0
6170       n_corr1=0
6171       if (nfgtasks.le.1) goto 30
6172       if (lprn) then
6173         write (iout,'(a)') 'Contact function values before RECEIVE:'
6174         do i=nnt,nct-2
6175           write (iout,'(2i3,50(1x,i2,f5.2))')
6176      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6177      &    j=1,num_cont_hb(i))
6178         enddo
6179       endif
6180       call flush(iout)
6181       do i=1,ntask_cont_from
6182         ncont_recv(i)=0
6183       enddo
6184       do i=1,ntask_cont_to
6185         ncont_sent(i)=0
6186       enddo
6187 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6188 c     & ntask_cont_to
6189 C Make the list of contacts to send to send to other procesors
6190 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6191 c      call flush(iout)
6192       do i=iturn3_start,iturn3_end
6193 c        write (iout,*) "make contact list turn3",i," num_cont",
6194 c     &    num_cont_hb(i)
6195         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6196       enddo
6197       do i=iturn4_start,iturn4_end
6198 c        write (iout,*) "make contact list turn4",i," num_cont",
6199 c     &   num_cont_hb(i)
6200         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6201       enddo
6202       do ii=1,nat_sent
6203         i=iat_sent(ii)
6204 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6205 c     &    num_cont_hb(i)
6206         do j=1,num_cont_hb(i)
6207         do k=1,4
6208           jjc=jcont_hb(j,i)
6209           iproc=iint_sent_local(k,jjc,ii)
6210 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6211           if (iproc.gt.0) then
6212             ncont_sent(iproc)=ncont_sent(iproc)+1
6213             nn=ncont_sent(iproc)
6214             zapas(1,nn,iproc)=i
6215             zapas(2,nn,iproc)=jjc
6216             zapas(3,nn,iproc)=facont_hb(j,i)
6217             zapas(4,nn,iproc)=ees0p(j,i)
6218             zapas(5,nn,iproc)=ees0m(j,i)
6219             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6220             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6221             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6222             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6223             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6224             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6225             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6226             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6227             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6228             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6229             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6230             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6231             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6232             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6233             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6234             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6235             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6236             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6237             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6238             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6239             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6240           endif
6241         enddo
6242         enddo
6243       enddo
6244       if (lprn) then
6245       write (iout,*)
6246      &  "Numbers of contacts to be sent to other processors",
6247      &  (ncont_sent(i),i=1,ntask_cont_to)
6248       write (iout,*) "Contacts sent"
6249       do ii=1,ntask_cont_to
6250         nn=ncont_sent(ii)
6251         iproc=itask_cont_to(ii)
6252         write (iout,*) nn," contacts to processor",iproc,
6253      &   " of CONT_TO_COMM group"
6254         do i=1,nn
6255           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6256         enddo
6257       enddo
6258       call flush(iout)
6259       endif
6260       CorrelType=477
6261       CorrelID=fg_rank+1
6262       CorrelType1=478
6263       CorrelID1=nfgtasks+fg_rank+1
6264       ireq=0
6265 C Receive the numbers of needed contacts from other processors
6266       do ii=1,ntask_cont_from
6267         iproc=itask_cont_from(ii)
6268         ireq=ireq+1
6269         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6270      &    FG_COMM,req(ireq),IERR)
6271       enddo
6272 c      write (iout,*) "IRECV ended"
6273 c      call flush(iout)
6274 C Send the number of contacts needed by other processors
6275       do ii=1,ntask_cont_to
6276         iproc=itask_cont_to(ii)
6277         ireq=ireq+1
6278         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6279      &    FG_COMM,req(ireq),IERR)
6280       enddo
6281 c      write (iout,*) "ISEND ended"
6282 c      write (iout,*) "number of requests (nn)",ireq
6283       call flush(iout)
6284       if (ireq.gt.0)
6285      &  call MPI_Waitall(ireq,req,status_array,ierr)
6286 c      write (iout,*)
6287 c     &  "Numbers of contacts to be received from other processors",
6288 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6289 c      call flush(iout)
6290 C Receive contacts
6291       ireq=0
6292       do ii=1,ntask_cont_from
6293         iproc=itask_cont_from(ii)
6294         nn=ncont_recv(ii)
6295 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6296 c     &   " of CONT_TO_COMM group"
6297         call flush(iout)
6298         if (nn.gt.0) then
6299           ireq=ireq+1
6300           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6301      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6302 c          write (iout,*) "ireq,req",ireq,req(ireq)
6303         endif
6304       enddo
6305 C Send the contacts to processors that need them
6306       do ii=1,ntask_cont_to
6307         iproc=itask_cont_to(ii)
6308         nn=ncont_sent(ii)
6309 c        write (iout,*) nn," contacts to processor",iproc,
6310 c     &   " of CONT_TO_COMM group"
6311         if (nn.gt.0) then
6312           ireq=ireq+1
6313           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6314      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6315 c          write (iout,*) "ireq,req",ireq,req(ireq)
6316 c          do i=1,nn
6317 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6318 c          enddo
6319         endif
6320       enddo
6321 c      write (iout,*) "number of requests (contacts)",ireq
6322 c      write (iout,*) "req",(req(i),i=1,4)
6323 c      call flush(iout)
6324       if (ireq.gt.0)
6325      & call MPI_Waitall(ireq,req,status_array,ierr)
6326       do iii=1,ntask_cont_from
6327         iproc=itask_cont_from(iii)
6328         nn=ncont_recv(iii)
6329         if (lprn) then
6330         write (iout,*) "Received",nn," contacts from processor",iproc,
6331      &   " of CONT_FROM_COMM group"
6332         call flush(iout)
6333         do i=1,nn
6334           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6335         enddo
6336         call flush(iout)
6337         endif
6338         do i=1,nn
6339           ii=zapas_recv(1,i,iii)
6340 c Flag the received contacts to prevent double-counting
6341           jj=-zapas_recv(2,i,iii)
6342 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6343 c          call flush(iout)
6344           nnn=num_cont_hb(ii)+1
6345           num_cont_hb(ii)=nnn
6346           jcont_hb(nnn,ii)=jj
6347           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6348           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6349           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6350           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6351           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6352           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6353           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6354           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6355           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6356           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6357           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6358           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6359           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6360           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6361           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6362           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6363           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6364           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6365           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6366           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6367           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6368           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6369           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6370           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6371         enddo
6372       enddo
6373       call flush(iout)
6374       if (lprn) then
6375         write (iout,'(a)') 'Contact function values after receive:'
6376         do i=nnt,nct-2
6377           write (iout,'(2i3,50(1x,i3,f5.2))')
6378      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6379      &    j=1,num_cont_hb(i))
6380         enddo
6381         call flush(iout)
6382       endif
6383    30 continue
6384 #endif
6385       if (lprn) then
6386         write (iout,'(a)') 'Contact function values:'
6387         do i=nnt,nct-2
6388           write (iout,'(2i3,50(1x,i3,f5.2))')
6389      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6390      &    j=1,num_cont_hb(i))
6391         enddo
6392       endif
6393       ecorr=0.0D0
6394 C Remove the loop below after debugging !!!
6395       do i=nnt,nct
6396         do j=1,3
6397           gradcorr(j,i)=0.0D0
6398           gradxorr(j,i)=0.0D0
6399         enddo
6400       enddo
6401 C Calculate the local-electrostatic correlation terms
6402       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6403         i1=i+1
6404         num_conti=num_cont_hb(i)
6405         num_conti1=num_cont_hb(i+1)
6406         do jj=1,num_conti
6407           j=jcont_hb(jj,i)
6408           jp=iabs(j)
6409           do kk=1,num_conti1
6410             j1=jcont_hb(kk,i1)
6411             jp1=iabs(j1)
6412 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6413 c     &         ' jj=',jj,' kk=',kk
6414             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6415      &          .or. j.lt.0 .and. j1.gt.0) .and.
6416      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6417 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6418 C The system gains extra energy.
6419               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6420               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6421      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6422               n_corr=n_corr+1
6423             else if (j1.eq.j) then
6424 C Contacts I-J and I-(J+1) occur simultaneously.
6425 C The system loses extra energy.
6426 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6427             endif
6428           enddo ! kk
6429           do kk=1,num_conti
6430             j1=jcont_hb(kk,i)
6431 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6432 c    &         ' jj=',jj,' kk=',kk
6433             if (j1.eq.j+1) then
6434 C Contacts I-J and (I+1)-J occur simultaneously.
6435 C The system loses extra energy.
6436 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6437             endif ! j1==j+1
6438           enddo ! kk
6439         enddo ! jj
6440       enddo ! i
6441       return
6442       end
6443 c------------------------------------------------------------------------------
6444       subroutine add_hb_contact(ii,jj,itask)
6445       implicit real*8 (a-h,o-z)
6446       include "DIMENSIONS"
6447       include "COMMON.IOUNITS"
6448       integer max_cont
6449       integer max_dim
6450       parameter (max_cont=maxconts)
6451       parameter (max_dim=26)
6452       include "COMMON.CONTACTS"
6453       double precision zapas(max_dim,maxconts,max_fg_procs),
6454      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6455       common /przechowalnia/ zapas
6456       integer i,j,ii,jj,iproc,itask(4),nn
6457 c      write (iout,*) "itask",itask
6458       do i=1,2
6459         iproc=itask(i)
6460         if (iproc.gt.0) then
6461           do j=1,num_cont_hb(ii)
6462             jjc=jcont_hb(j,ii)
6463 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6464             if (jjc.eq.jj) then
6465               ncont_sent(iproc)=ncont_sent(iproc)+1
6466               nn=ncont_sent(iproc)
6467               zapas(1,nn,iproc)=ii
6468               zapas(2,nn,iproc)=jjc
6469               zapas(3,nn,iproc)=facont_hb(j,ii)
6470               zapas(4,nn,iproc)=ees0p(j,ii)
6471               zapas(5,nn,iproc)=ees0m(j,ii)
6472               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6473               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6474               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6475               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6476               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6477               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6478               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6479               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6480               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6481               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6482               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6483               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6484               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6485               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6486               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6487               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6488               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6489               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6490               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6491               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6492               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6493               exit
6494             endif
6495           enddo
6496         endif
6497       enddo
6498       return
6499       end
6500 c------------------------------------------------------------------------------
6501       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6502      &  n_corr1)
6503 C This subroutine calculates multi-body contributions to hydrogen-bonding
6504       implicit real*8 (a-h,o-z)
6505       include 'DIMENSIONS'
6506       include 'COMMON.IOUNITS'
6507 #ifdef MPI
6508       include "mpif.h"
6509       parameter (max_cont=maxconts)
6510       parameter (max_dim=70)
6511       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6512       double precision zapas(max_dim,maxconts,max_fg_procs),
6513      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6514       common /przechowalnia/ zapas
6515       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6516      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6517 #endif
6518       include 'COMMON.SETUP'
6519       include 'COMMON.FFIELD'
6520       include 'COMMON.DERIV'
6521       include 'COMMON.LOCAL'
6522       include 'COMMON.INTERACT'
6523       include 'COMMON.CONTACTS'
6524       include 'COMMON.CHAIN'
6525       include 'COMMON.CONTROL'
6526       double precision gx(3),gx1(3)
6527       integer num_cont_hb_old(maxres)
6528       logical lprn,ldone
6529       double precision eello4,eello5,eelo6,eello_turn6
6530       external eello4,eello5,eello6,eello_turn6
6531 C Set lprn=.true. for debugging
6532       lprn=.false.
6533       eturn6=0.0d0
6534 #ifdef MPI
6535       do i=1,nres
6536         num_cont_hb_old(i)=num_cont_hb(i)
6537       enddo
6538       n_corr=0
6539       n_corr1=0
6540       if (nfgtasks.le.1) goto 30
6541       if (lprn) then
6542         write (iout,'(a)') 'Contact function values before RECEIVE:'
6543         do i=nnt,nct-2
6544           write (iout,'(2i3,50(1x,i2,f5.2))')
6545      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6546      &    j=1,num_cont_hb(i))
6547         enddo
6548       endif
6549       call flush(iout)
6550       do i=1,ntask_cont_from
6551         ncont_recv(i)=0
6552       enddo
6553       do i=1,ntask_cont_to
6554         ncont_sent(i)=0
6555       enddo
6556 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6557 c     & ntask_cont_to
6558 C Make the list of contacts to send to send to other procesors
6559       do i=iturn3_start,iturn3_end
6560 c        write (iout,*) "make contact list turn3",i," num_cont",
6561 c     &    num_cont_hb(i)
6562         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6563       enddo
6564       do i=iturn4_start,iturn4_end
6565 c        write (iout,*) "make contact list turn4",i," num_cont",
6566 c     &   num_cont_hb(i)
6567         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6568       enddo
6569       do ii=1,nat_sent
6570         i=iat_sent(ii)
6571 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6572 c     &    num_cont_hb(i)
6573         do j=1,num_cont_hb(i)
6574         do k=1,4
6575           jjc=jcont_hb(j,i)
6576           iproc=iint_sent_local(k,jjc,ii)
6577 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6578           if (iproc.ne.0) then
6579             ncont_sent(iproc)=ncont_sent(iproc)+1
6580             nn=ncont_sent(iproc)
6581             zapas(1,nn,iproc)=i
6582             zapas(2,nn,iproc)=jjc
6583             zapas(3,nn,iproc)=d_cont(j,i)
6584             ind=3
6585             do kk=1,3
6586               ind=ind+1
6587               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6588             enddo
6589             do kk=1,2
6590               do ll=1,2
6591                 ind=ind+1
6592                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6593               enddo
6594             enddo
6595             do jj=1,5
6596               do kk=1,3
6597                 do ll=1,2
6598                   do mm=1,2
6599                     ind=ind+1
6600                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6601                   enddo
6602                 enddo
6603               enddo
6604             enddo
6605           endif
6606         enddo
6607         enddo
6608       enddo
6609       if (lprn) then
6610       write (iout,*)
6611      &  "Numbers of contacts to be sent to other processors",
6612      &  (ncont_sent(i),i=1,ntask_cont_to)
6613       write (iout,*) "Contacts sent"
6614       do ii=1,ntask_cont_to
6615         nn=ncont_sent(ii)
6616         iproc=itask_cont_to(ii)
6617         write (iout,*) nn," contacts to processor",iproc,
6618      &   " of CONT_TO_COMM group"
6619         do i=1,nn
6620           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6621         enddo
6622       enddo
6623       call flush(iout)
6624       endif
6625       CorrelType=477
6626       CorrelID=fg_rank+1
6627       CorrelType1=478
6628       CorrelID1=nfgtasks+fg_rank+1
6629       ireq=0
6630 C Receive the numbers of needed contacts from other processors
6631       do ii=1,ntask_cont_from
6632         iproc=itask_cont_from(ii)
6633         ireq=ireq+1
6634         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6635      &    FG_COMM,req(ireq),IERR)
6636       enddo
6637 c      write (iout,*) "IRECV ended"
6638 c      call flush(iout)
6639 C Send the number of contacts needed by other processors
6640       do ii=1,ntask_cont_to
6641         iproc=itask_cont_to(ii)
6642         ireq=ireq+1
6643         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6644      &    FG_COMM,req(ireq),IERR)
6645       enddo
6646 c      write (iout,*) "ISEND ended"
6647 c      write (iout,*) "number of requests (nn)",ireq
6648       call flush(iout)
6649       if (ireq.gt.0)
6650      &  call MPI_Waitall(ireq,req,status_array,ierr)
6651 c      write (iout,*)
6652 c     &  "Numbers of contacts to be received from other processors",
6653 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6654 c      call flush(iout)
6655 C Receive contacts
6656       ireq=0
6657       do ii=1,ntask_cont_from
6658         iproc=itask_cont_from(ii)
6659         nn=ncont_recv(ii)
6660 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6661 c     &   " of CONT_TO_COMM group"
6662         call flush(iout)
6663         if (nn.gt.0) then
6664           ireq=ireq+1
6665           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6666      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6667 c          write (iout,*) "ireq,req",ireq,req(ireq)
6668         endif
6669       enddo
6670 C Send the contacts to processors that need them
6671       do ii=1,ntask_cont_to
6672         iproc=itask_cont_to(ii)
6673         nn=ncont_sent(ii)
6674 c        write (iout,*) nn," contacts to processor",iproc,
6675 c     &   " of CONT_TO_COMM group"
6676         if (nn.gt.0) then
6677           ireq=ireq+1
6678           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6679      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6680 c          write (iout,*) "ireq,req",ireq,req(ireq)
6681 c          do i=1,nn
6682 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6683 c          enddo
6684         endif
6685       enddo
6686 c      write (iout,*) "number of requests (contacts)",ireq
6687 c      write (iout,*) "req",(req(i),i=1,4)
6688 c      call flush(iout)
6689       if (ireq.gt.0)
6690      & call MPI_Waitall(ireq,req,status_array,ierr)
6691       do iii=1,ntask_cont_from
6692         iproc=itask_cont_from(iii)
6693         nn=ncont_recv(iii)
6694         if (lprn) then
6695         write (iout,*) "Received",nn," contacts from processor",iproc,
6696      &   " of CONT_FROM_COMM group"
6697         call flush(iout)
6698         do i=1,nn
6699           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6700         enddo
6701         call flush(iout)
6702         endif
6703         do i=1,nn
6704           ii=zapas_recv(1,i,iii)
6705 c Flag the received contacts to prevent double-counting
6706           jj=-zapas_recv(2,i,iii)
6707 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6708 c          call flush(iout)
6709           nnn=num_cont_hb(ii)+1
6710           num_cont_hb(ii)=nnn
6711           jcont_hb(nnn,ii)=jj
6712           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6713           ind=3
6714           do kk=1,3
6715             ind=ind+1
6716             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6717           enddo
6718           do kk=1,2
6719             do ll=1,2
6720               ind=ind+1
6721               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6722             enddo
6723           enddo
6724           do jj=1,5
6725             do kk=1,3
6726               do ll=1,2
6727                 do mm=1,2
6728                   ind=ind+1
6729                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6730                 enddo
6731               enddo
6732             enddo
6733           enddo
6734         enddo
6735       enddo
6736       call flush(iout)
6737       if (lprn) then
6738         write (iout,'(a)') 'Contact function values after receive:'
6739         do i=nnt,nct-2
6740           write (iout,'(2i3,50(1x,i3,5f6.3))')
6741      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6742      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6743         enddo
6744         call flush(iout)
6745       endif
6746    30 continue
6747 #endif
6748       if (lprn) then
6749         write (iout,'(a)') 'Contact function values:'
6750         do i=nnt,nct-2
6751           write (iout,'(2i3,50(1x,i2,5f6.3))')
6752      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6753      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6754         enddo
6755       endif
6756       ecorr=0.0D0
6757       ecorr5=0.0d0
6758       ecorr6=0.0d0
6759 C Remove the loop below after debugging !!!
6760       do i=nnt,nct
6761         do j=1,3
6762           gradcorr(j,i)=0.0D0
6763           gradxorr(j,i)=0.0D0
6764         enddo
6765       enddo
6766 C Calculate the dipole-dipole interaction energies
6767       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6768       do i=iatel_s,iatel_e+1
6769         num_conti=num_cont_hb(i)
6770         do jj=1,num_conti
6771           j=jcont_hb(jj,i)
6772 #ifdef MOMENT
6773           call dipole(i,j,jj)
6774 #endif
6775         enddo
6776       enddo
6777       endif
6778 C Calculate the local-electrostatic correlation terms
6779 c                write (iout,*) "gradcorr5 in eello5 before loop"
6780 c                do iii=1,nres
6781 c                  write (iout,'(i5,3f10.5)')
6782 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6783 c                enddo
6784       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6785 c        write (iout,*) "corr loop i",i
6786         i1=i+1
6787         num_conti=num_cont_hb(i)
6788         num_conti1=num_cont_hb(i+1)
6789         do jj=1,num_conti
6790           j=jcont_hb(jj,i)
6791           jp=iabs(j)
6792           do kk=1,num_conti1
6793             j1=jcont_hb(kk,i1)
6794             jp1=iabs(j1)
6795 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6796 c     &         ' jj=',jj,' kk=',kk
6797 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6798             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6799      &          .or. j.lt.0 .and. j1.gt.0) .and.
6800      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6801 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6802 C The system gains extra energy.
6803               n_corr=n_corr+1
6804               sqd1=dsqrt(d_cont(jj,i))
6805               sqd2=dsqrt(d_cont(kk,i1))
6806               sred_geom = sqd1*sqd2
6807               IF (sred_geom.lt.cutoff_corr) THEN
6808                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6809      &            ekont,fprimcont)
6810 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6811 cd     &         ' jj=',jj,' kk=',kk
6812                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6813                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6814                 do l=1,3
6815                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6816                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6817                 enddo
6818                 n_corr1=n_corr1+1
6819 cd               write (iout,*) 'sred_geom=',sred_geom,
6820 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6821 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6822 cd               write (iout,*) "g_contij",g_contij
6823 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6824 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6825                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6826                 if (wcorr4.gt.0.0d0)
6827      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6828                   if (energy_dec.and.wcorr4.gt.0.0d0)
6829      1                 write (iout,'(a6,4i5,0pf7.3)')
6830      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6831 c                write (iout,*) "gradcorr5 before eello5"
6832 c                do iii=1,nres
6833 c                  write (iout,'(i5,3f10.5)')
6834 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6835 c                enddo
6836                 if (wcorr5.gt.0.0d0)
6837      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6838 c                write (iout,*) "gradcorr5 after eello5"
6839 c                do iii=1,nres
6840 c                  write (iout,'(i5,3f10.5)')
6841 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6842 c                enddo
6843                   if (energy_dec.and.wcorr5.gt.0.0d0)
6844      1                 write (iout,'(a6,4i5,0pf7.3)')
6845      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6846 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6847 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6848                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6849      &               .or. wturn6.eq.0.0d0))then
6850 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6851                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6852                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6853      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6854 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6855 cd     &            'ecorr6=',ecorr6
6856 cd                write (iout,'(4e15.5)') sred_geom,
6857 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6858 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6859 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6860                 else if (wturn6.gt.0.0d0
6861      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6862 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6863                   eturn6=eturn6+eello_turn6(i,jj,kk)
6864                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6865      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6866 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6867                 endif
6868               ENDIF
6869 1111          continue
6870             endif
6871           enddo ! kk
6872         enddo ! jj
6873       enddo ! i
6874       do i=1,nres
6875         num_cont_hb(i)=num_cont_hb_old(i)
6876       enddo
6877 c                write (iout,*) "gradcorr5 in eello5"
6878 c                do iii=1,nres
6879 c                  write (iout,'(i5,3f10.5)')
6880 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6881 c                enddo
6882       return
6883       end
6884 c------------------------------------------------------------------------------
6885       subroutine add_hb_contact_eello(ii,jj,itask)
6886       implicit real*8 (a-h,o-z)
6887       include "DIMENSIONS"
6888       include "COMMON.IOUNITS"
6889       integer max_cont
6890       integer max_dim
6891       parameter (max_cont=maxconts)
6892       parameter (max_dim=70)
6893       include "COMMON.CONTACTS"
6894       double precision zapas(max_dim,maxconts,max_fg_procs),
6895      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6896       common /przechowalnia/ zapas
6897       integer i,j,ii,jj,iproc,itask(4),nn
6898 c      write (iout,*) "itask",itask
6899       do i=1,2
6900         iproc=itask(i)
6901         if (iproc.gt.0) then
6902           do j=1,num_cont_hb(ii)
6903             jjc=jcont_hb(j,ii)
6904 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6905             if (jjc.eq.jj) then
6906               ncont_sent(iproc)=ncont_sent(iproc)+1
6907               nn=ncont_sent(iproc)
6908               zapas(1,nn,iproc)=ii
6909               zapas(2,nn,iproc)=jjc
6910               zapas(3,nn,iproc)=d_cont(j,ii)
6911               ind=3
6912               do kk=1,3
6913                 ind=ind+1
6914                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6915               enddo
6916               do kk=1,2
6917                 do ll=1,2
6918                   ind=ind+1
6919                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6920                 enddo
6921               enddo
6922               do jj=1,5
6923                 do kk=1,3
6924                   do ll=1,2
6925                     do mm=1,2
6926                       ind=ind+1
6927                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6928                     enddo
6929                   enddo
6930                 enddo
6931               enddo
6932               exit
6933             endif
6934           enddo
6935         endif
6936       enddo
6937       return
6938       end
6939 c------------------------------------------------------------------------------
6940       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6941       implicit real*8 (a-h,o-z)
6942       include 'DIMENSIONS'
6943       include 'COMMON.IOUNITS'
6944       include 'COMMON.DERIV'
6945       include 'COMMON.INTERACT'
6946       include 'COMMON.CONTACTS'
6947       double precision gx(3),gx1(3)
6948       logical lprn
6949       lprn=.false.
6950       eij=facont_hb(jj,i)
6951       ekl=facont_hb(kk,k)
6952       ees0pij=ees0p(jj,i)
6953       ees0pkl=ees0p(kk,k)
6954       ees0mij=ees0m(jj,i)
6955       ees0mkl=ees0m(kk,k)
6956       ekont=eij*ekl
6957       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6958 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6959 C Following 4 lines for diagnostics.
6960 cd    ees0pkl=0.0D0
6961 cd    ees0pij=1.0D0
6962 cd    ees0mkl=0.0D0
6963 cd    ees0mij=1.0D0
6964 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6965 c     & 'Contacts ',i,j,
6966 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6967 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6968 c     & 'gradcorr_long'
6969 C Calculate the multi-body contribution to energy.
6970 c      ecorr=ecorr+ekont*ees
6971 C Calculate multi-body contributions to the gradient.
6972       coeffpees0pij=coeffp*ees0pij
6973       coeffmees0mij=coeffm*ees0mij
6974       coeffpees0pkl=coeffp*ees0pkl
6975       coeffmees0mkl=coeffm*ees0mkl
6976       do ll=1,3
6977 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6978         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6979      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6980      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6981         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6982      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6983      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6984 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6985         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6986      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6987      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6988         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6989      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6990      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6991         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6992      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6993      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6994         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6995         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6996         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6997      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6998      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6999         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7000         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7001 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7002       enddo
7003 c      write (iout,*)
7004 cgrad      do m=i+1,j-1
7005 cgrad        do ll=1,3
7006 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7007 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7008 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7009 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7010 cgrad        enddo
7011 cgrad      enddo
7012 cgrad      do m=k+1,l-1
7013 cgrad        do ll=1,3
7014 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7015 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7016 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7017 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7018 cgrad        enddo
7019 cgrad      enddo
7020 c      write (iout,*) "ehbcorr",ekont*ees
7021       ehbcorr=ekont*ees
7022       return
7023       end
7024 #ifdef MOMENT
7025 C---------------------------------------------------------------------------
7026       subroutine dipole(i,j,jj)
7027       implicit real*8 (a-h,o-z)
7028       include 'DIMENSIONS'
7029       include 'COMMON.IOUNITS'
7030       include 'COMMON.CHAIN'
7031       include 'COMMON.FFIELD'
7032       include 'COMMON.DERIV'
7033       include 'COMMON.INTERACT'
7034       include 'COMMON.CONTACTS'
7035       include 'COMMON.TORSION'
7036       include 'COMMON.VAR'
7037       include 'COMMON.GEO'
7038       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7039      &  auxmat(2,2)
7040       iti1 = itortyp(itype(i+1))
7041       if (j.lt.nres-1) then
7042         itj1 = itortyp(itype(j+1))
7043       else
7044         itj1=ntortyp+1
7045       endif
7046       do iii=1,2
7047         dipi(iii,1)=Ub2(iii,i)
7048         dipderi(iii)=Ub2der(iii,i)
7049         dipi(iii,2)=b1(iii,i+1)
7050         dipj(iii,1)=Ub2(iii,j)
7051         dipderj(iii)=Ub2der(iii,j)
7052         dipj(iii,2)=b1(iii,j+1)
7053       enddo
7054       kkk=0
7055       do iii=1,2
7056         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7057         do jjj=1,2
7058           kkk=kkk+1
7059           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7060         enddo
7061       enddo
7062       do kkk=1,5
7063         do lll=1,3
7064           mmm=0
7065           do iii=1,2
7066             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7067      &        auxvec(1))
7068             do jjj=1,2
7069               mmm=mmm+1
7070               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7071             enddo
7072           enddo
7073         enddo
7074       enddo
7075       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7076       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7077       do iii=1,2
7078         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7079       enddo
7080       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7081       do iii=1,2
7082         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7083       enddo
7084       return
7085       end
7086 #endif
7087 C---------------------------------------------------------------------------
7088       subroutine calc_eello(i,j,k,l,jj,kk)
7089 C
7090 C This subroutine computes matrices and vectors needed to calculate
7091 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7092 C
7093       implicit real*8 (a-h,o-z)
7094       include 'DIMENSIONS'
7095       include 'COMMON.IOUNITS'
7096       include 'COMMON.CHAIN'
7097       include 'COMMON.DERIV'
7098       include 'COMMON.INTERACT'
7099       include 'COMMON.CONTACTS'
7100       include 'COMMON.TORSION'
7101       include 'COMMON.VAR'
7102       include 'COMMON.GEO'
7103       include 'COMMON.FFIELD'
7104       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7105      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7106       logical lprn
7107       common /kutas/ lprn
7108 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7109 cd     & ' jj=',jj,' kk=',kk
7110 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7111 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7112 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7113       do iii=1,2
7114         do jjj=1,2
7115           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7116           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7117         enddo
7118       enddo
7119       call transpose2(aa1(1,1),aa1t(1,1))
7120       call transpose2(aa2(1,1),aa2t(1,1))
7121       do kkk=1,5
7122         do lll=1,3
7123           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7124      &      aa1tder(1,1,lll,kkk))
7125           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7126      &      aa2tder(1,1,lll,kkk))
7127         enddo
7128       enddo
7129       if (l.eq.j+1) then
7130 C parallel orientation of the two CA-CA-CA frames.
7131         if (i.gt.1) then
7132           iti=itortyp(itype(i))
7133         else
7134           iti=ntortyp+1
7135         endif
7136         itk1=itortyp(itype(k+1))
7137         itj=itortyp(itype(j))
7138         if (l.lt.nres-1) then
7139           itl1=itortyp(itype(l+1))
7140         else
7141           itl1=ntortyp+1
7142         endif
7143 C A1 kernel(j+1) A2T
7144 cd        do iii=1,2
7145 cd          write (iout,'(3f10.5,5x,3f10.5)')
7146 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7147 cd        enddo
7148         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7149      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7150      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7151 C Following matrices are needed only for 6-th order cumulants
7152         IF (wcorr6.gt.0.0d0) THEN
7153         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7154      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7155      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7156         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7157      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7158      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7159      &   ADtEAderx(1,1,1,1,1,1))
7160         lprn=.false.
7161         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7162      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7163      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7164      &   ADtEA1derx(1,1,1,1,1,1))
7165         ENDIF
7166 C End 6-th order cumulants
7167 cd        lprn=.false.
7168 cd        if (lprn) then
7169 cd        write (2,*) 'In calc_eello6'
7170 cd        do iii=1,2
7171 cd          write (2,*) 'iii=',iii
7172 cd          do kkk=1,5
7173 cd            write (2,*) 'kkk=',kkk
7174 cd            do jjj=1,2
7175 cd              write (2,'(3(2f10.5),5x)')
7176 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7177 cd            enddo
7178 cd          enddo
7179 cd        enddo
7180 cd        endif
7181         call transpose2(EUgder(1,1,k),auxmat(1,1))
7182         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7183         call transpose2(EUg(1,1,k),auxmat(1,1))
7184         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7185         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7186         do iii=1,2
7187           do kkk=1,5
7188             do lll=1,3
7189               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7190      &          EAEAderx(1,1,lll,kkk,iii,1))
7191             enddo
7192           enddo
7193         enddo
7194 C A1T kernel(i+1) A2
7195         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7196      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7197      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7198 C Following matrices are needed only for 6-th order cumulants
7199         IF (wcorr6.gt.0.0d0) THEN
7200         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7201      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7202      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7203         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7204      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7205      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7206      &   ADtEAderx(1,1,1,1,1,2))
7207         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7208      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7209      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7210      &   ADtEA1derx(1,1,1,1,1,2))
7211         ENDIF
7212 C End 6-th order cumulants
7213         call transpose2(EUgder(1,1,l),auxmat(1,1))
7214         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7215         call transpose2(EUg(1,1,l),auxmat(1,1))
7216         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7217         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7218         do iii=1,2
7219           do kkk=1,5
7220             do lll=1,3
7221               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7222      &          EAEAderx(1,1,lll,kkk,iii,2))
7223             enddo
7224           enddo
7225         enddo
7226 C AEAb1 and AEAb2
7227 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7228 C They are needed only when the fifth- or the sixth-order cumulants are
7229 C indluded.
7230         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7231         call transpose2(AEA(1,1,1),auxmat(1,1))
7232         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7233         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7234         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7235         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7236         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7237         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7238         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7239         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7240         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7241         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7242         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7243         call transpose2(AEA(1,1,2),auxmat(1,1))
7244         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7245         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7246         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7247         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7248         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7249         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7250         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7251         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7252         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7253         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7254         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7255 C Calculate the Cartesian derivatives of the vectors.
7256         do iii=1,2
7257           do kkk=1,5
7258             do lll=1,3
7259               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7260               call matvec2(auxmat(1,1),b1(1,i),
7261      &          AEAb1derx(1,lll,kkk,iii,1,1))
7262               call matvec2(auxmat(1,1),Ub2(1,i),
7263      &          AEAb2derx(1,lll,kkk,iii,1,1))
7264               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7265      &          AEAb1derx(1,lll,kkk,iii,2,1))
7266               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7267      &          AEAb2derx(1,lll,kkk,iii,2,1))
7268               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7269               call matvec2(auxmat(1,1),b1(1,j),
7270      &          AEAb1derx(1,lll,kkk,iii,1,2))
7271               call matvec2(auxmat(1,1),Ub2(1,j),
7272      &          AEAb2derx(1,lll,kkk,iii,1,2))
7273               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7274      &          AEAb1derx(1,lll,kkk,iii,2,2))
7275               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7276      &          AEAb2derx(1,lll,kkk,iii,2,2))
7277             enddo
7278           enddo
7279         enddo
7280         ENDIF
7281 C End vectors
7282       else
7283 C Antiparallel orientation of the two CA-CA-CA frames.
7284         if (i.gt.1) then
7285           iti=itortyp(itype(i))
7286         else
7287           iti=ntortyp+1
7288         endif
7289         itk1=itortyp(itype(k+1))
7290         itl=itortyp(itype(l))
7291         itj=itortyp(itype(j))
7292         if (j.lt.nres-1) then
7293           itj1=itortyp(itype(j+1))
7294         else
7295           itj1=ntortyp+1
7296         endif
7297 C A2 kernel(j-1)T A1T
7298         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7299      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7300      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7301 C Following matrices are needed only for 6-th order cumulants
7302         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7303      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7304         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7305      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7306      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7307         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7308      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7309      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7310      &   ADtEAderx(1,1,1,1,1,1))
7311         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7312      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7313      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7314      &   ADtEA1derx(1,1,1,1,1,1))
7315         ENDIF
7316 C End 6-th order cumulants
7317         call transpose2(EUgder(1,1,k),auxmat(1,1))
7318         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7319         call transpose2(EUg(1,1,k),auxmat(1,1))
7320         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7321         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7322         do iii=1,2
7323           do kkk=1,5
7324             do lll=1,3
7325               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7326      &          EAEAderx(1,1,lll,kkk,iii,1))
7327             enddo
7328           enddo
7329         enddo
7330 C A2T kernel(i+1)T A1
7331         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7332      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7333      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7334 C Following matrices are needed only for 6-th order cumulants
7335         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7336      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7337         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7338      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7339      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7340         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7341      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7342      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7343      &   ADtEAderx(1,1,1,1,1,2))
7344         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7345      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7346      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7347      &   ADtEA1derx(1,1,1,1,1,2))
7348         ENDIF
7349 C End 6-th order cumulants
7350         call transpose2(EUgder(1,1,j),auxmat(1,1))
7351         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7352         call transpose2(EUg(1,1,j),auxmat(1,1))
7353         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7354         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7355         do iii=1,2
7356           do kkk=1,5
7357             do lll=1,3
7358               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7359      &          EAEAderx(1,1,lll,kkk,iii,2))
7360             enddo
7361           enddo
7362         enddo
7363 C AEAb1 and AEAb2
7364 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7365 C They are needed only when the fifth- or the sixth-order cumulants are
7366 C indluded.
7367         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7368      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7369         call transpose2(AEA(1,1,1),auxmat(1,1))
7370         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7371         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7372         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7373         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7374         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7375         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7376         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7377         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7378         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7379         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7380         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7381         call transpose2(AEA(1,1,2),auxmat(1,1))
7382         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7383         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7384         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7385         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7386         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7387         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7388         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7389         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7390         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7391         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7392         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7393 C Calculate the Cartesian derivatives of the vectors.
7394         do iii=1,2
7395           do kkk=1,5
7396             do lll=1,3
7397               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7398               call matvec2(auxmat(1,1),b1(1,i),
7399      &          AEAb1derx(1,lll,kkk,iii,1,1))
7400               call matvec2(auxmat(1,1),Ub2(1,i),
7401      &          AEAb2derx(1,lll,kkk,iii,1,1))
7402               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7403      &          AEAb1derx(1,lll,kkk,iii,2,1))
7404               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7405      &          AEAb2derx(1,lll,kkk,iii,2,1))
7406               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7407               call matvec2(auxmat(1,1),b1(1,l),
7408      &          AEAb1derx(1,lll,kkk,iii,1,2))
7409               call matvec2(auxmat(1,1),Ub2(1,l),
7410      &          AEAb2derx(1,lll,kkk,iii,1,2))
7411               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7412      &          AEAb1derx(1,lll,kkk,iii,2,2))
7413               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7414      &          AEAb2derx(1,lll,kkk,iii,2,2))
7415             enddo
7416           enddo
7417         enddo
7418         ENDIF
7419 C End vectors
7420       endif
7421       return
7422       end
7423 C---------------------------------------------------------------------------
7424       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7425      &  KK,KKderg,AKA,AKAderg,AKAderx)
7426       implicit none
7427       integer nderg
7428       logical transp
7429       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7430      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7431      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7432       integer iii,kkk,lll
7433       integer jjj,mmm
7434       logical lprn
7435       common /kutas/ lprn
7436       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7437       do iii=1,nderg
7438         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7439      &    AKAderg(1,1,iii))
7440       enddo
7441 cd      if (lprn) write (2,*) 'In kernel'
7442       do kkk=1,5
7443 cd        if (lprn) write (2,*) 'kkk=',kkk
7444         do lll=1,3
7445           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7446      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7447 cd          if (lprn) then
7448 cd            write (2,*) 'lll=',lll
7449 cd            write (2,*) 'iii=1'
7450 cd            do jjj=1,2
7451 cd              write (2,'(3(2f10.5),5x)')
7452 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7453 cd            enddo
7454 cd          endif
7455           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7456      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7457 cd          if (lprn) then
7458 cd            write (2,*) 'lll=',lll
7459 cd            write (2,*) 'iii=2'
7460 cd            do jjj=1,2
7461 cd              write (2,'(3(2f10.5),5x)')
7462 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7463 cd            enddo
7464 cd          endif
7465         enddo
7466       enddo
7467       return
7468       end
7469 C---------------------------------------------------------------------------
7470       double precision function eello4(i,j,k,l,jj,kk)
7471       implicit real*8 (a-h,o-z)
7472       include 'DIMENSIONS'
7473       include 'COMMON.IOUNITS'
7474       include 'COMMON.CHAIN'
7475       include 'COMMON.DERIV'
7476       include 'COMMON.INTERACT'
7477       include 'COMMON.CONTACTS'
7478       include 'COMMON.TORSION'
7479       include 'COMMON.VAR'
7480       include 'COMMON.GEO'
7481       double precision pizda(2,2),ggg1(3),ggg2(3)
7482 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7483 cd        eello4=0.0d0
7484 cd        return
7485 cd      endif
7486 cd      print *,'eello4:',i,j,k,l,jj,kk
7487 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7488 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7489 cold      eij=facont_hb(jj,i)
7490 cold      ekl=facont_hb(kk,k)
7491 cold      ekont=eij*ekl
7492       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7493 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7494       gcorr_loc(k-1)=gcorr_loc(k-1)
7495      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7496       if (l.eq.j+1) then
7497         gcorr_loc(l-1)=gcorr_loc(l-1)
7498      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7499       else
7500         gcorr_loc(j-1)=gcorr_loc(j-1)
7501      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7502       endif
7503       do iii=1,2
7504         do kkk=1,5
7505           do lll=1,3
7506             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7507      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7508 cd            derx(lll,kkk,iii)=0.0d0
7509           enddo
7510         enddo
7511       enddo
7512 cd      gcorr_loc(l-1)=0.0d0
7513 cd      gcorr_loc(j-1)=0.0d0
7514 cd      gcorr_loc(k-1)=0.0d0
7515 cd      eel4=1.0d0
7516 cd      write (iout,*)'Contacts have occurred for peptide groups',
7517 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7518 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7519       if (j.lt.nres-1) then
7520         j1=j+1
7521         j2=j-1
7522       else
7523         j1=j-1
7524         j2=j-2
7525       endif
7526       if (l.lt.nres-1) then
7527         l1=l+1
7528         l2=l-1
7529       else
7530         l1=l-1
7531         l2=l-2
7532       endif
7533       do ll=1,3
7534 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7535 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7536         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7537         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7538 cgrad        ghalf=0.5d0*ggg1(ll)
7539         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7540         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7541         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7542         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7543         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7544         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7545 cgrad        ghalf=0.5d0*ggg2(ll)
7546         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7547         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7548         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7549         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7550         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7551         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7552       enddo
7553 cgrad      do m=i+1,j-1
7554 cgrad        do ll=1,3
7555 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7556 cgrad        enddo
7557 cgrad      enddo
7558 cgrad      do m=k+1,l-1
7559 cgrad        do ll=1,3
7560 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7561 cgrad        enddo
7562 cgrad      enddo
7563 cgrad      do m=i+2,j2
7564 cgrad        do ll=1,3
7565 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7566 cgrad        enddo
7567 cgrad      enddo
7568 cgrad      do m=k+2,l2
7569 cgrad        do ll=1,3
7570 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7571 cgrad        enddo
7572 cgrad      enddo
7573 cd      do iii=1,nres-3
7574 cd        write (2,*) iii,gcorr_loc(iii)
7575 cd      enddo
7576       eello4=ekont*eel4
7577 cd      write (2,*) 'ekont',ekont
7578 cd      write (iout,*) 'eello4',ekont*eel4
7579       return
7580       end
7581 C---------------------------------------------------------------------------
7582       double precision function eello5(i,j,k,l,jj,kk)
7583       implicit real*8 (a-h,o-z)
7584       include 'DIMENSIONS'
7585       include 'COMMON.IOUNITS'
7586       include 'COMMON.CHAIN'
7587       include 'COMMON.DERIV'
7588       include 'COMMON.INTERACT'
7589       include 'COMMON.CONTACTS'
7590       include 'COMMON.TORSION'
7591       include 'COMMON.VAR'
7592       include 'COMMON.GEO'
7593       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7594       double precision ggg1(3),ggg2(3)
7595 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7596 C                                                                              C
7597 C                            Parallel chains                                   C
7598 C                                                                              C
7599 C          o             o                   o             o                   C
7600 C         /l\           / \             \   / \           / \   /              C
7601 C        /   \         /   \             \ /   \         /   \ /               C
7602 C       j| o |l1       | o |              o| o |         | o |o                C
7603 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7604 C      \i/   \         /   \ /             /   \         /   \                 C
7605 C       o    k1             o                                                  C
7606 C         (I)          (II)                (III)          (IV)                 C
7607 C                                                                              C
7608 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7609 C                                                                              C
7610 C                            Antiparallel chains                               C
7611 C                                                                              C
7612 C          o             o                   o             o                   C
7613 C         /j\           / \             \   / \           / \   /              C
7614 C        /   \         /   \             \ /   \         /   \ /               C
7615 C      j1| o |l        | o |              o| o |         | o |o                C
7616 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7617 C      \i/   \         /   \ /             /   \         /   \                 C
7618 C       o     k1            o                                                  C
7619 C         (I)          (II)                (III)          (IV)                 C
7620 C                                                                              C
7621 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7622 C                                                                              C
7623 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7624 C                                                                              C
7625 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7626 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7627 cd        eello5=0.0d0
7628 cd        return
7629 cd      endif
7630 cd      write (iout,*)
7631 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7632 cd     &   ' and',k,l
7633       itk=itortyp(itype(k))
7634       itl=itortyp(itype(l))
7635       itj=itortyp(itype(j))
7636       eello5_1=0.0d0
7637       eello5_2=0.0d0
7638       eello5_3=0.0d0
7639       eello5_4=0.0d0
7640 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7641 cd     &   eel5_3_num,eel5_4_num)
7642       do iii=1,2
7643         do kkk=1,5
7644           do lll=1,3
7645             derx(lll,kkk,iii)=0.0d0
7646           enddo
7647         enddo
7648       enddo
7649 cd      eij=facont_hb(jj,i)
7650 cd      ekl=facont_hb(kk,k)
7651 cd      ekont=eij*ekl
7652 cd      write (iout,*)'Contacts have occurred for peptide groups',
7653 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7654 cd      goto 1111
7655 C Contribution from the graph I.
7656 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7657 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7658       call transpose2(EUg(1,1,k),auxmat(1,1))
7659       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7660       vv(1)=pizda(1,1)-pizda(2,2)
7661       vv(2)=pizda(1,2)+pizda(2,1)
7662       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7663      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7664 C Explicit gradient in virtual-dihedral angles.
7665       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7666      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7667      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7668       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7669       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7670       vv(1)=pizda(1,1)-pizda(2,2)
7671       vv(2)=pizda(1,2)+pizda(2,1)
7672       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7673      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7674      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7675       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7676       vv(1)=pizda(1,1)-pizda(2,2)
7677       vv(2)=pizda(1,2)+pizda(2,1)
7678       if (l.eq.j+1) then
7679         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7680      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7681      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7682       else
7683         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7684      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7685      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7686       endif
7687 C Cartesian gradient
7688       do iii=1,2
7689         do kkk=1,5
7690           do lll=1,3
7691             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7692      &        pizda(1,1))
7693             vv(1)=pizda(1,1)-pizda(2,2)
7694             vv(2)=pizda(1,2)+pizda(2,1)
7695             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7696      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7697      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7698           enddo
7699         enddo
7700       enddo
7701 c      goto 1112
7702 c1111  continue
7703 C Contribution from graph II
7704       call transpose2(EE(1,1,itk),auxmat(1,1))
7705       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7706       vv(1)=pizda(1,1)+pizda(2,2)
7707       vv(2)=pizda(2,1)-pizda(1,2)
7708       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7709      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7710 C Explicit gradient in virtual-dihedral angles.
7711       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7712      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7713       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7714       vv(1)=pizda(1,1)+pizda(2,2)
7715       vv(2)=pizda(2,1)-pizda(1,2)
7716       if (l.eq.j+1) then
7717         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7718      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7719      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7720       else
7721         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7722      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7723      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7724       endif
7725 C Cartesian gradient
7726       do iii=1,2
7727         do kkk=1,5
7728           do lll=1,3
7729             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7730      &        pizda(1,1))
7731             vv(1)=pizda(1,1)+pizda(2,2)
7732             vv(2)=pizda(2,1)-pizda(1,2)
7733             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7734      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7735      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7736           enddo
7737         enddo
7738       enddo
7739 cd      goto 1112
7740 cd1111  continue
7741       if (l.eq.j+1) then
7742 cd        goto 1110
7743 C Parallel orientation
7744 C Contribution from graph III
7745         call transpose2(EUg(1,1,l),auxmat(1,1))
7746         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7747         vv(1)=pizda(1,1)-pizda(2,2)
7748         vv(2)=pizda(1,2)+pizda(2,1)
7749         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7750      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7751 C Explicit gradient in virtual-dihedral angles.
7752         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7753      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7754      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7755         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7756         vv(1)=pizda(1,1)-pizda(2,2)
7757         vv(2)=pizda(1,2)+pizda(2,1)
7758         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7759      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7760      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7761         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7762         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7763         vv(1)=pizda(1,1)-pizda(2,2)
7764         vv(2)=pizda(1,2)+pizda(2,1)
7765         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7766      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7767      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7768 C Cartesian gradient
7769         do iii=1,2
7770           do kkk=1,5
7771             do lll=1,3
7772               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7773      &          pizda(1,1))
7774               vv(1)=pizda(1,1)-pizda(2,2)
7775               vv(2)=pizda(1,2)+pizda(2,1)
7776               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7777      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7778      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7779             enddo
7780           enddo
7781         enddo
7782 cd        goto 1112
7783 C Contribution from graph IV
7784 cd1110    continue
7785         call transpose2(EE(1,1,itl),auxmat(1,1))
7786         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7787         vv(1)=pizda(1,1)+pizda(2,2)
7788         vv(2)=pizda(2,1)-pizda(1,2)
7789         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7790      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7791 C Explicit gradient in virtual-dihedral angles.
7792         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7793      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7794         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7795         vv(1)=pizda(1,1)+pizda(2,2)
7796         vv(2)=pizda(2,1)-pizda(1,2)
7797         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7798      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7799      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7800 C Cartesian gradient
7801         do iii=1,2
7802           do kkk=1,5
7803             do lll=1,3
7804               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7805      &          pizda(1,1))
7806               vv(1)=pizda(1,1)+pizda(2,2)
7807               vv(2)=pizda(2,1)-pizda(1,2)
7808               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7809      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7810      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7811             enddo
7812           enddo
7813         enddo
7814       else
7815 C Antiparallel orientation
7816 C Contribution from graph III
7817 c        goto 1110
7818         call transpose2(EUg(1,1,j),auxmat(1,1))
7819         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7820         vv(1)=pizda(1,1)-pizda(2,2)
7821         vv(2)=pizda(1,2)+pizda(2,1)
7822         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7823      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7824 C Explicit gradient in virtual-dihedral angles.
7825         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7826      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7827      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7828         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7829         vv(1)=pizda(1,1)-pizda(2,2)
7830         vv(2)=pizda(1,2)+pizda(2,1)
7831         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7832      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7833      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7834         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7835         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7836         vv(1)=pizda(1,1)-pizda(2,2)
7837         vv(2)=pizda(1,2)+pizda(2,1)
7838         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7839      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7840      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7841 C Cartesian gradient
7842         do iii=1,2
7843           do kkk=1,5
7844             do lll=1,3
7845               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7846      &          pizda(1,1))
7847               vv(1)=pizda(1,1)-pizda(2,2)
7848               vv(2)=pizda(1,2)+pizda(2,1)
7849               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7850      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7851      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7852             enddo
7853           enddo
7854         enddo
7855 cd        goto 1112
7856 C Contribution from graph IV
7857 1110    continue
7858         call transpose2(EE(1,1,itj),auxmat(1,1))
7859         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7860         vv(1)=pizda(1,1)+pizda(2,2)
7861         vv(2)=pizda(2,1)-pizda(1,2)
7862         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7863      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7864 C Explicit gradient in virtual-dihedral angles.
7865         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7866      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7867         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7868         vv(1)=pizda(1,1)+pizda(2,2)
7869         vv(2)=pizda(2,1)-pizda(1,2)
7870         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7871      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7872      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7873 C Cartesian gradient
7874         do iii=1,2
7875           do kkk=1,5
7876             do lll=1,3
7877               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7878      &          pizda(1,1))
7879               vv(1)=pizda(1,1)+pizda(2,2)
7880               vv(2)=pizda(2,1)-pizda(1,2)
7881               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7882      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7883      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7884             enddo
7885           enddo
7886         enddo
7887       endif
7888 1112  continue
7889       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7890 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7891 cd        write (2,*) 'ijkl',i,j,k,l
7892 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7893 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7894 cd      endif
7895 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7896 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7897 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7898 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7899       if (j.lt.nres-1) then
7900         j1=j+1
7901         j2=j-1
7902       else
7903         j1=j-1
7904         j2=j-2
7905       endif
7906       if (l.lt.nres-1) then
7907         l1=l+1
7908         l2=l-1
7909       else
7910         l1=l-1
7911         l2=l-2
7912       endif
7913 cd      eij=1.0d0
7914 cd      ekl=1.0d0
7915 cd      ekont=1.0d0
7916 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7917 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7918 C        summed up outside the subrouine as for the other subroutines
7919 C        handling long-range interactions. The old code is commented out
7920 C        with "cgrad" to keep track of changes.
7921       do ll=1,3
7922 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7923 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7924         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7925         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7926 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7927 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7928 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7929 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7930 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7931 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7932 c     &   gradcorr5ij,
7933 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7934 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7935 cgrad        ghalf=0.5d0*ggg1(ll)
7936 cd        ghalf=0.0d0
7937         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7938         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7939         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7940         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7941         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7942         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7943 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7944 cgrad        ghalf=0.5d0*ggg2(ll)
7945 cd        ghalf=0.0d0
7946         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7947         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7948         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7949         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7950         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7951         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7952       enddo
7953 cd      goto 1112
7954 cgrad      do m=i+1,j-1
7955 cgrad        do ll=1,3
7956 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7957 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7958 cgrad        enddo
7959 cgrad      enddo
7960 cgrad      do m=k+1,l-1
7961 cgrad        do ll=1,3
7962 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7963 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7964 cgrad        enddo
7965 cgrad      enddo
7966 c1112  continue
7967 cgrad      do m=i+2,j2
7968 cgrad        do ll=1,3
7969 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7970 cgrad        enddo
7971 cgrad      enddo
7972 cgrad      do m=k+2,l2
7973 cgrad        do ll=1,3
7974 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7975 cgrad        enddo
7976 cgrad      enddo
7977 cd      do iii=1,nres-3
7978 cd        write (2,*) iii,g_corr5_loc(iii)
7979 cd      enddo
7980       eello5=ekont*eel5
7981 cd      write (2,*) 'ekont',ekont
7982 cd      write (iout,*) 'eello5',ekont*eel5
7983       return
7984       end
7985 c--------------------------------------------------------------------------
7986       double precision function eello6(i,j,k,l,jj,kk)
7987       implicit real*8 (a-h,o-z)
7988       include 'DIMENSIONS'
7989       include 'COMMON.IOUNITS'
7990       include 'COMMON.CHAIN'
7991       include 'COMMON.DERIV'
7992       include 'COMMON.INTERACT'
7993       include 'COMMON.CONTACTS'
7994       include 'COMMON.TORSION'
7995       include 'COMMON.VAR'
7996       include 'COMMON.GEO'
7997       include 'COMMON.FFIELD'
7998       double precision ggg1(3),ggg2(3)
7999 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8000 cd        eello6=0.0d0
8001 cd        return
8002 cd      endif
8003 cd      write (iout,*)
8004 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8005 cd     &   ' and',k,l
8006       eello6_1=0.0d0
8007       eello6_2=0.0d0
8008       eello6_3=0.0d0
8009       eello6_4=0.0d0
8010       eello6_5=0.0d0
8011       eello6_6=0.0d0
8012 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8013 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8014       do iii=1,2
8015         do kkk=1,5
8016           do lll=1,3
8017             derx(lll,kkk,iii)=0.0d0
8018           enddo
8019         enddo
8020       enddo
8021 cd      eij=facont_hb(jj,i)
8022 cd      ekl=facont_hb(kk,k)
8023 cd      ekont=eij*ekl
8024 cd      eij=1.0d0
8025 cd      ekl=1.0d0
8026 cd      ekont=1.0d0
8027       if (l.eq.j+1) then
8028         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8029         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8030         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8031         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8032         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8033         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8034       else
8035         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8036         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8037         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8038         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8039         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8040           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8041         else
8042           eello6_5=0.0d0
8043         endif
8044         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8045       endif
8046 C If turn contributions are considered, they will be handled separately.
8047       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8048 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8049 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8050 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8051 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8052 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8053 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8054 cd      goto 1112
8055       if (j.lt.nres-1) then
8056         j1=j+1
8057         j2=j-1
8058       else
8059         j1=j-1
8060         j2=j-2
8061       endif
8062       if (l.lt.nres-1) then
8063         l1=l+1
8064         l2=l-1
8065       else
8066         l1=l-1
8067         l2=l-2
8068       endif
8069       do ll=1,3
8070 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8071 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8072 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8073 cgrad        ghalf=0.5d0*ggg1(ll)
8074 cd        ghalf=0.0d0
8075         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8076         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8077         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8078         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8079         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8080         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8081         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8082         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8083 cgrad        ghalf=0.5d0*ggg2(ll)
8084 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8085 cd        ghalf=0.0d0
8086         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8087         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8088         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8089         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8090         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8091         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8092       enddo
8093 cd      goto 1112
8094 cgrad      do m=i+1,j-1
8095 cgrad        do ll=1,3
8096 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8097 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8098 cgrad        enddo
8099 cgrad      enddo
8100 cgrad      do m=k+1,l-1
8101 cgrad        do ll=1,3
8102 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8103 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8104 cgrad        enddo
8105 cgrad      enddo
8106 cgrad1112  continue
8107 cgrad      do m=i+2,j2
8108 cgrad        do ll=1,3
8109 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8110 cgrad        enddo
8111 cgrad      enddo
8112 cgrad      do m=k+2,l2
8113 cgrad        do ll=1,3
8114 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8115 cgrad        enddo
8116 cgrad      enddo
8117 cd      do iii=1,nres-3
8118 cd        write (2,*) iii,g_corr6_loc(iii)
8119 cd      enddo
8120       eello6=ekont*eel6
8121 cd      write (2,*) 'ekont',ekont
8122 cd      write (iout,*) 'eello6',ekont*eel6
8123       return
8124       end
8125 c--------------------------------------------------------------------------
8126       double precision function eello6_graph1(i,j,k,l,imat,swap)
8127       implicit real*8 (a-h,o-z)
8128       include 'DIMENSIONS'
8129       include 'COMMON.IOUNITS'
8130       include 'COMMON.CHAIN'
8131       include 'COMMON.DERIV'
8132       include 'COMMON.INTERACT'
8133       include 'COMMON.CONTACTS'
8134       include 'COMMON.TORSION'
8135       include 'COMMON.VAR'
8136       include 'COMMON.GEO'
8137       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8138       logical swap
8139       logical lprn
8140       common /kutas/ lprn
8141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8142 C                                                                              C
8143 C      Parallel       Antiparallel                                             C
8144 C                                                                              C
8145 C          o             o                                                     C
8146 C         /l\           /j\                                                    C
8147 C        /   \         /   \                                                   C
8148 C       /| o |         | o |\                                                  C
8149 C     \ j|/k\|  /   \  |/k\|l /                                                C
8150 C      \ /   \ /     \ /   \ /                                                 C
8151 C       o     o       o     o                                                  C
8152 C       i             i                                                        C
8153 C                                                                              C
8154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8155       itk=itortyp(itype(k))
8156       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8157       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8158       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8159       call transpose2(EUgC(1,1,k),auxmat(1,1))
8160       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8161       vv1(1)=pizda1(1,1)-pizda1(2,2)
8162       vv1(2)=pizda1(1,2)+pizda1(2,1)
8163       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8164       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8165       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8166       s5=scalar2(vv(1),Dtobr2(1,i))
8167 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8168       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8169       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8170      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8171      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8172      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8173      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8174      & +scalar2(vv(1),Dtobr2der(1,i)))
8175       call matmat2(AEAderg(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       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8179       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8180       if (l.eq.j+1) then
8181         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8182      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8183      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8184      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8185      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8186       else
8187         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8188      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8189      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8190      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8191      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8192       endif
8193       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8194       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8195       vv1(1)=pizda1(1,1)-pizda1(2,2)
8196       vv1(2)=pizda1(1,2)+pizda1(2,1)
8197       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8198      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8199      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8200      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8201       do iii=1,2
8202         if (swap) then
8203           ind=3-iii
8204         else
8205           ind=iii
8206         endif
8207         do kkk=1,5
8208           do lll=1,3
8209             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8210             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8211             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8212             call transpose2(EUgC(1,1,k),auxmat(1,1))
8213             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8214      &        pizda1(1,1))
8215             vv1(1)=pizda1(1,1)-pizda1(2,2)
8216             vv1(2)=pizda1(1,2)+pizda1(2,1)
8217             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8218             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8219      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8220             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8221      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8222             s5=scalar2(vv(1),Dtobr2(1,i))
8223             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8224           enddo
8225         enddo
8226       enddo
8227       return
8228       end
8229 c----------------------------------------------------------------------------
8230       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8231       implicit real*8 (a-h,o-z)
8232       include 'DIMENSIONS'
8233       include 'COMMON.IOUNITS'
8234       include 'COMMON.CHAIN'
8235       include 'COMMON.DERIV'
8236       include 'COMMON.INTERACT'
8237       include 'COMMON.CONTACTS'
8238       include 'COMMON.TORSION'
8239       include 'COMMON.VAR'
8240       include 'COMMON.GEO'
8241       logical swap
8242       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8243      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8244       logical lprn
8245       common /kutas/ lprn
8246 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8247 C                                                                              C
8248 C      Parallel       Antiparallel                                             C
8249 C                                                                              C
8250 C          o             o                                                     C
8251 C     \   /l\           /j\   /                                                C
8252 C      \ /   \         /   \ /                                                 C
8253 C       o| o |         | o |o                                                  C
8254 C     \ j|/k\|      \  |/k\|l                                                  C
8255 C      \ /   \       \ /   \                                                   C
8256 C       o             o                                                        C
8257 C       i             i                                                        C
8258 C                                                                              C
8259 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8260 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8261 C AL 7/4/01 s1 would occur in the sixth-order moment,
8262 C           but not in a cluster cumulant
8263 #ifdef MOMENT
8264       s1=dip(1,jj,i)*dip(1,kk,k)
8265 #endif
8266       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8267       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8268       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8269       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8270       call transpose2(EUg(1,1,k),auxmat(1,1))
8271       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8272       vv(1)=pizda(1,1)-pizda(2,2)
8273       vv(2)=pizda(1,2)+pizda(2,1)
8274       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8275 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8276 #ifdef MOMENT
8277       eello6_graph2=-(s1+s2+s3+s4)
8278 #else
8279       eello6_graph2=-(s2+s3+s4)
8280 #endif
8281 c      eello6_graph2=-s3
8282 C Derivatives in gamma(i-1)
8283       if (i.gt.1) then
8284 #ifdef MOMENT
8285         s1=dipderg(1,jj,i)*dip(1,kk,k)
8286 #endif
8287         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8288         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8289         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8290         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8291 #ifdef MOMENT
8292         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8293 #else
8294         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8295 #endif
8296 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8297       endif
8298 C Derivatives in gamma(k-1)
8299 #ifdef MOMENT
8300       s1=dip(1,jj,i)*dipderg(1,kk,k)
8301 #endif
8302       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8303       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8304       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8305       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8306       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8307       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8308       vv(1)=pizda(1,1)-pizda(2,2)
8309       vv(2)=pizda(1,2)+pizda(2,1)
8310       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8311 #ifdef MOMENT
8312       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8313 #else
8314       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8315 #endif
8316 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8317 C Derivatives in gamma(j-1) or gamma(l-1)
8318       if (j.gt.1) then
8319 #ifdef MOMENT
8320         s1=dipderg(3,jj,i)*dip(1,kk,k)
8321 #endif
8322         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8323         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8324         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8325         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8326         vv(1)=pizda(1,1)-pizda(2,2)
8327         vv(2)=pizda(1,2)+pizda(2,1)
8328         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8329 #ifdef MOMENT
8330         if (swap) then
8331           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8332         else
8333           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8334         endif
8335 #endif
8336         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8337 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8338       endif
8339 C Derivatives in gamma(l-1) or gamma(j-1)
8340       if (l.gt.1) then
8341 #ifdef MOMENT
8342         s1=dip(1,jj,i)*dipderg(3,kk,k)
8343 #endif
8344         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8345         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8346         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8347         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8348         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8349         vv(1)=pizda(1,1)-pizda(2,2)
8350         vv(2)=pizda(1,2)+pizda(2,1)
8351         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8352 #ifdef MOMENT
8353         if (swap) then
8354           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8355         else
8356           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8357         endif
8358 #endif
8359         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8360 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8361       endif
8362 C Cartesian derivatives.
8363       if (lprn) then
8364         write (2,*) 'In eello6_graph2'
8365         do iii=1,2
8366           write (2,*) 'iii=',iii
8367           do kkk=1,5
8368             write (2,*) 'kkk=',kkk
8369             do jjj=1,2
8370               write (2,'(3(2f10.5),5x)')
8371      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8372             enddo
8373           enddo
8374         enddo
8375       endif
8376       do iii=1,2
8377         do kkk=1,5
8378           do lll=1,3
8379 #ifdef MOMENT
8380             if (iii.eq.1) then
8381               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8382             else
8383               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8384             endif
8385 #endif
8386             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8387      &        auxvec(1))
8388             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8389             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8390      &        auxvec(1))
8391             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8392             call transpose2(EUg(1,1,k),auxmat(1,1))
8393             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8394      &        pizda(1,1))
8395             vv(1)=pizda(1,1)-pizda(2,2)
8396             vv(2)=pizda(1,2)+pizda(2,1)
8397             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8398 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8399 #ifdef MOMENT
8400             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8401 #else
8402             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8403 #endif
8404             if (swap) then
8405               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8406             else
8407               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8408             endif
8409           enddo
8410         enddo
8411       enddo
8412       return
8413       end
8414 c----------------------------------------------------------------------------
8415       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8416       implicit real*8 (a-h,o-z)
8417       include 'DIMENSIONS'
8418       include 'COMMON.IOUNITS'
8419       include 'COMMON.CHAIN'
8420       include 'COMMON.DERIV'
8421       include 'COMMON.INTERACT'
8422       include 'COMMON.CONTACTS'
8423       include 'COMMON.TORSION'
8424       include 'COMMON.VAR'
8425       include 'COMMON.GEO'
8426       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8427       logical swap
8428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8429 C                                                                              C
8430 C      Parallel       Antiparallel                                             C
8431 C                                                                              C
8432 C          o             o                                                     C
8433 C         /l\   /   \   /j\                                                    C
8434 C        /   \ /     \ /   \                                                   C
8435 C       /| o |o       o| o |\                                                  C
8436 C       j|/k\|  /      |/k\|l /                                                C
8437 C        /   \ /       /   \ /                                                 C
8438 C       /     o       /     o                                                  C
8439 C       i             i                                                        C
8440 C                                                                              C
8441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8442 C
8443 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8444 C           energy moment and not to the cluster cumulant.
8445       iti=itortyp(itype(i))
8446       if (j.lt.nres-1) then
8447         itj1=itortyp(itype(j+1))
8448       else
8449         itj1=ntortyp+1
8450       endif
8451       itk=itortyp(itype(k))
8452       itk1=itortyp(itype(k+1))
8453       if (l.lt.nres-1) then
8454         itl1=itortyp(itype(l+1))
8455       else
8456         itl1=ntortyp+1
8457       endif
8458 #ifdef MOMENT
8459       s1=dip(4,jj,i)*dip(4,kk,k)
8460 #endif
8461       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8462       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8463       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8464       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8465       call transpose2(EE(1,1,itk),auxmat(1,1))
8466       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8467       vv(1)=pizda(1,1)+pizda(2,2)
8468       vv(2)=pizda(2,1)-pizda(1,2)
8469       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8470 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8471 cd     & "sum",-(s2+s3+s4)
8472 #ifdef MOMENT
8473       eello6_graph3=-(s1+s2+s3+s4)
8474 #else
8475       eello6_graph3=-(s2+s3+s4)
8476 #endif
8477 c      eello6_graph3=-s4
8478 C Derivatives in gamma(k-1)
8479       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8480       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8481       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8482       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8483 C Derivatives in gamma(l-1)
8484       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8485       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8486       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8487       vv(1)=pizda(1,1)+pizda(2,2)
8488       vv(2)=pizda(2,1)-pizda(1,2)
8489       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8490       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8491 C Cartesian derivatives.
8492       do iii=1,2
8493         do kkk=1,5
8494           do lll=1,3
8495 #ifdef MOMENT
8496             if (iii.eq.1) then
8497               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8498             else
8499               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8500             endif
8501 #endif
8502             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8503      &        auxvec(1))
8504             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8505             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8506      &        auxvec(1))
8507             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8508             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8509      &        pizda(1,1))
8510             vv(1)=pizda(1,1)+pizda(2,2)
8511             vv(2)=pizda(2,1)-pizda(1,2)
8512             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8513 #ifdef MOMENT
8514             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8515 #else
8516             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8517 #endif
8518             if (swap) then
8519               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8520             else
8521               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8522             endif
8523 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8524           enddo
8525         enddo
8526       enddo
8527       return
8528       end
8529 c----------------------------------------------------------------------------
8530       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8531       implicit real*8 (a-h,o-z)
8532       include 'DIMENSIONS'
8533       include 'COMMON.IOUNITS'
8534       include 'COMMON.CHAIN'
8535       include 'COMMON.DERIV'
8536       include 'COMMON.INTERACT'
8537       include 'COMMON.CONTACTS'
8538       include 'COMMON.TORSION'
8539       include 'COMMON.VAR'
8540       include 'COMMON.GEO'
8541       include 'COMMON.FFIELD'
8542       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8543      & auxvec1(2),auxmat1(2,2)
8544       logical swap
8545 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8546 C                                                                              C
8547 C      Parallel       Antiparallel                                             C
8548 C                                                                              C
8549 C          o             o                                                     C
8550 C         /l\   /   \   /j\                                                    C
8551 C        /   \ /     \ /   \                                                   C
8552 C       /| o |o       o| o |\                                                  C
8553 C     \ j|/k\|      \  |/k\|l                                                  C
8554 C      \ /   \       \ /   \                                                   C
8555 C       o     \       o     \                                                  C
8556 C       i             i                                                        C
8557 C                                                                              C
8558 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8559 C
8560 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8561 C           energy moment and not to the cluster cumulant.
8562 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8563       iti=itortyp(itype(i))
8564       itj=itortyp(itype(j))
8565       if (j.lt.nres-1) then
8566         itj1=itortyp(itype(j+1))
8567       else
8568         itj1=ntortyp+1
8569       endif
8570       itk=itortyp(itype(k))
8571       if (k.lt.nres-1) then
8572         itk1=itortyp(itype(k+1))
8573       else
8574         itk1=ntortyp+1
8575       endif
8576       itl=itortyp(itype(l))
8577       if (l.lt.nres-1) then
8578         itl1=itortyp(itype(l+1))
8579       else
8580         itl1=ntortyp+1
8581       endif
8582 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8583 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8584 cd     & ' itl',itl,' itl1',itl1
8585 #ifdef MOMENT
8586       if (imat.eq.1) then
8587         s1=dip(3,jj,i)*dip(3,kk,k)
8588       else
8589         s1=dip(2,jj,j)*dip(2,kk,l)
8590       endif
8591 #endif
8592       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8593       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8594       if (j.eq.l+1) then
8595         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8596         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8597       else
8598         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8599         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8600       endif
8601       call transpose2(EUg(1,1,k),auxmat(1,1))
8602       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8603       vv(1)=pizda(1,1)-pizda(2,2)
8604       vv(2)=pizda(2,1)+pizda(1,2)
8605       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8606 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8607 #ifdef MOMENT
8608       eello6_graph4=-(s1+s2+s3+s4)
8609 #else
8610       eello6_graph4=-(s2+s3+s4)
8611 #endif
8612 C Derivatives in gamma(i-1)
8613       if (i.gt.1) then
8614 #ifdef MOMENT
8615         if (imat.eq.1) then
8616           s1=dipderg(2,jj,i)*dip(3,kk,k)
8617         else
8618           s1=dipderg(4,jj,j)*dip(2,kk,l)
8619         endif
8620 #endif
8621         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8622         if (j.eq.l+1) then
8623           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8624           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8625         else
8626           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8627           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8628         endif
8629         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8630         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8631 cd          write (2,*) 'turn6 derivatives'
8632 #ifdef MOMENT
8633           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8634 #else
8635           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8636 #endif
8637         else
8638 #ifdef MOMENT
8639           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8640 #else
8641           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8642 #endif
8643         endif
8644       endif
8645 C Derivatives in gamma(k-1)
8646 #ifdef MOMENT
8647       if (imat.eq.1) then
8648         s1=dip(3,jj,i)*dipderg(2,kk,k)
8649       else
8650         s1=dip(2,jj,j)*dipderg(4,kk,l)
8651       endif
8652 #endif
8653       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8654       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8655       if (j.eq.l+1) then
8656         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8657         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8658       else
8659         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8660         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8661       endif
8662       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8663       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8664       vv(1)=pizda(1,1)-pizda(2,2)
8665       vv(2)=pizda(2,1)+pizda(1,2)
8666       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8667       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8668 #ifdef MOMENT
8669         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8670 #else
8671         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8672 #endif
8673       else
8674 #ifdef MOMENT
8675         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8676 #else
8677         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8678 #endif
8679       endif
8680 C Derivatives in gamma(j-1) or gamma(l-1)
8681       if (l.eq.j+1 .and. l.gt.1) then
8682         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8683         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8684         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8685         vv(1)=pizda(1,1)-pizda(2,2)
8686         vv(2)=pizda(2,1)+pizda(1,2)
8687         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8688         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8689       else if (j.gt.1) then
8690         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8691         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8692         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8693         vv(1)=pizda(1,1)-pizda(2,2)
8694         vv(2)=pizda(2,1)+pizda(1,2)
8695         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8696         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8697           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8698         else
8699           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8700         endif
8701       endif
8702 C Cartesian derivatives.
8703       do iii=1,2
8704         do kkk=1,5
8705           do lll=1,3
8706 #ifdef MOMENT
8707             if (iii.eq.1) then
8708               if (imat.eq.1) then
8709                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8710               else
8711                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8712               endif
8713             else
8714               if (imat.eq.1) then
8715                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8716               else
8717                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8718               endif
8719             endif
8720 #endif
8721             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8722      &        auxvec(1))
8723             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8724             if (j.eq.l+1) then
8725               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8726      &          b1(1,j+1),auxvec(1))
8727               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8728             else
8729               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8730      &          b1(1,l+1),auxvec(1))
8731               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8732             endif
8733             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8734      &        pizda(1,1))
8735             vv(1)=pizda(1,1)-pizda(2,2)
8736             vv(2)=pizda(2,1)+pizda(1,2)
8737             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8738             if (swap) then
8739               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8740 #ifdef MOMENT
8741                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8742      &             -(s1+s2+s4)
8743 #else
8744                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8745      &             -(s2+s4)
8746 #endif
8747                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8748               else
8749 #ifdef MOMENT
8750                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8751 #else
8752                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8753 #endif
8754                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8755               endif
8756             else
8757 #ifdef MOMENT
8758               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8759 #else
8760               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8761 #endif
8762               if (l.eq.j+1) then
8763                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8764               else
8765                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8766               endif
8767             endif
8768           enddo
8769         enddo
8770       enddo
8771       return
8772       end
8773 c----------------------------------------------------------------------------
8774       double precision function eello_turn6(i,jj,kk)
8775       implicit real*8 (a-h,o-z)
8776       include 'DIMENSIONS'
8777       include 'COMMON.IOUNITS'
8778       include 'COMMON.CHAIN'
8779       include 'COMMON.DERIV'
8780       include 'COMMON.INTERACT'
8781       include 'COMMON.CONTACTS'
8782       include 'COMMON.TORSION'
8783       include 'COMMON.VAR'
8784       include 'COMMON.GEO'
8785       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8786      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8787      &  ggg1(3),ggg2(3)
8788       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8789      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8790 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8791 C           the respective energy moment and not to the cluster cumulant.
8792       s1=0.0d0
8793       s8=0.0d0
8794       s13=0.0d0
8795 c
8796       eello_turn6=0.0d0
8797       j=i+4
8798       k=i+1
8799       l=i+3
8800       iti=itortyp(itype(i))
8801       itk=itortyp(itype(k))
8802       itk1=itortyp(itype(k+1))
8803       itl=itortyp(itype(l))
8804       itj=itortyp(itype(j))
8805 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8806 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8807 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8808 cd        eello6=0.0d0
8809 cd        return
8810 cd      endif
8811 cd      write (iout,*)
8812 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8813 cd     &   ' and',k,l
8814 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8815       do iii=1,2
8816         do kkk=1,5
8817           do lll=1,3
8818             derx_turn(lll,kkk,iii)=0.0d0
8819           enddo
8820         enddo
8821       enddo
8822 cd      eij=1.0d0
8823 cd      ekl=1.0d0
8824 cd      ekont=1.0d0
8825       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8826 cd      eello6_5=0.0d0
8827 cd      write (2,*) 'eello6_5',eello6_5
8828 #ifdef MOMENT
8829       call transpose2(AEA(1,1,1),auxmat(1,1))
8830       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8831       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8832       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8833 #endif
8834       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8835       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8836       s2 = scalar2(b1(1,k),vtemp1(1))
8837 #ifdef MOMENT
8838       call transpose2(AEA(1,1,2),atemp(1,1))
8839       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8840       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8841       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8842 #endif
8843       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8844       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8845       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8846 #ifdef MOMENT
8847       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8848       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8849       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8850       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8851       ss13 = scalar2(b1(1,k),vtemp4(1))
8852       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8853 #endif
8854 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8855 c      s1=0.0d0
8856 c      s2=0.0d0
8857 c      s8=0.0d0
8858 c      s12=0.0d0
8859 c      s13=0.0d0
8860       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8861 C Derivatives in gamma(i+2)
8862       s1d =0.0d0
8863       s8d =0.0d0
8864 #ifdef MOMENT
8865       call transpose2(AEA(1,1,1),auxmatd(1,1))
8866       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8867       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8868       call transpose2(AEAderg(1,1,2),atempd(1,1))
8869       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8870       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8871 #endif
8872       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8873       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8874       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8875 c      s1d=0.0d0
8876 c      s2d=0.0d0
8877 c      s8d=0.0d0
8878 c      s12d=0.0d0
8879 c      s13d=0.0d0
8880       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8881 C Derivatives in gamma(i+3)
8882 #ifdef MOMENT
8883       call transpose2(AEA(1,1,1),auxmatd(1,1))
8884       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8885       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8886       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8887 #endif
8888       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8889       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8890       s2d = scalar2(b1(1,k),vtemp1d(1))
8891 #ifdef MOMENT
8892       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8893       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8894 #endif
8895       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8896 #ifdef MOMENT
8897       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8898       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8899       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8900 #endif
8901 c      s1d=0.0d0
8902 c      s2d=0.0d0
8903 c      s8d=0.0d0
8904 c      s12d=0.0d0
8905 c      s13d=0.0d0
8906 #ifdef MOMENT
8907       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8908      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8909 #else
8910       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8911      &               -0.5d0*ekont*(s2d+s12d)
8912 #endif
8913 C Derivatives in gamma(i+4)
8914       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8915       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8916       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8917 #ifdef MOMENT
8918       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8919       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8920       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8921 #endif
8922 c      s1d=0.0d0
8923 c      s2d=0.0d0
8924 c      s8d=0.0d0
8925 C      s12d=0.0d0
8926 c      s13d=0.0d0
8927 #ifdef MOMENT
8928       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8929 #else
8930       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8931 #endif
8932 C Derivatives in gamma(i+5)
8933 #ifdef MOMENT
8934       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8935       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8936       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8937 #endif
8938       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8939       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8940       s2d = scalar2(b1(1,k),vtemp1d(1))
8941 #ifdef MOMENT
8942       call transpose2(AEA(1,1,2),atempd(1,1))
8943       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8944       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8945 #endif
8946       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8947       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8948 #ifdef MOMENT
8949       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8950       ss13d = scalar2(b1(1,k),vtemp4d(1))
8951       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8952 #endif
8953 c      s1d=0.0d0
8954 c      s2d=0.0d0
8955 c      s8d=0.0d0
8956 c      s12d=0.0d0
8957 c      s13d=0.0d0
8958 #ifdef MOMENT
8959       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8960      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8961 #else
8962       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8963      &               -0.5d0*ekont*(s2d+s12d)
8964 #endif
8965 C Cartesian derivatives
8966       do iii=1,2
8967         do kkk=1,5
8968           do lll=1,3
8969 #ifdef MOMENT
8970             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8971             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8972             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8973 #endif
8974             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8975             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8976      &          vtemp1d(1))
8977             s2d = scalar2(b1(1,k),vtemp1d(1))
8978 #ifdef MOMENT
8979             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8980             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8981             s8d = -(atempd(1,1)+atempd(2,2))*
8982      &           scalar2(cc(1,1,itl),vtemp2(1))
8983 #endif
8984             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8985      &           auxmatd(1,1))
8986             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8987             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8988 c      s1d=0.0d0
8989 c      s2d=0.0d0
8990 c      s8d=0.0d0
8991 c      s12d=0.0d0
8992 c      s13d=0.0d0
8993 #ifdef MOMENT
8994             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8995      &        - 0.5d0*(s1d+s2d)
8996 #else
8997             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8998      &        - 0.5d0*s2d
8999 #endif
9000 #ifdef MOMENT
9001             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9002      &        - 0.5d0*(s8d+s12d)
9003 #else
9004             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9005      &        - 0.5d0*s12d
9006 #endif
9007           enddo
9008         enddo
9009       enddo
9010 #ifdef MOMENT
9011       do kkk=1,5
9012         do lll=1,3
9013           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9014      &      achuj_tempd(1,1))
9015           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9016           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9017           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9018           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9019           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9020      &      vtemp4d(1))
9021           ss13d = scalar2(b1(1,k),vtemp4d(1))
9022           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9023           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9024         enddo
9025       enddo
9026 #endif
9027 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9028 cd     &  16*eel_turn6_num
9029 cd      goto 1112
9030       if (j.lt.nres-1) then
9031         j1=j+1
9032         j2=j-1
9033       else
9034         j1=j-1
9035         j2=j-2
9036       endif
9037       if (l.lt.nres-1) then
9038         l1=l+1
9039         l2=l-1
9040       else
9041         l1=l-1
9042         l2=l-2
9043       endif
9044       do ll=1,3
9045 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9046 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9047 cgrad        ghalf=0.5d0*ggg1(ll)
9048 cd        ghalf=0.0d0
9049         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9050         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9051         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9052      &    +ekont*derx_turn(ll,2,1)
9053         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9054         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9055      &    +ekont*derx_turn(ll,4,1)
9056         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9057         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9058         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9059 cgrad        ghalf=0.5d0*ggg2(ll)
9060 cd        ghalf=0.0d0
9061         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9062      &    +ekont*derx_turn(ll,2,2)
9063         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9064         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9065      &    +ekont*derx_turn(ll,4,2)
9066         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9067         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9068         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9069       enddo
9070 cd      goto 1112
9071 cgrad      do m=i+1,j-1
9072 cgrad        do ll=1,3
9073 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9074 cgrad        enddo
9075 cgrad      enddo
9076 cgrad      do m=k+1,l-1
9077 cgrad        do ll=1,3
9078 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9079 cgrad        enddo
9080 cgrad      enddo
9081 cgrad1112  continue
9082 cgrad      do m=i+2,j2
9083 cgrad        do ll=1,3
9084 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9085 cgrad        enddo
9086 cgrad      enddo
9087 cgrad      do m=k+2,l2
9088 cgrad        do ll=1,3
9089 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9090 cgrad        enddo
9091 cgrad      enddo
9092 cd      do iii=1,nres-3
9093 cd        write (2,*) iii,g_corr6_loc(iii)
9094 cd      enddo
9095       eello_turn6=ekont*eel_turn6
9096 cd      write (2,*) 'ekont',ekont
9097 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9098       return
9099       end
9100
9101 C-----------------------------------------------------------------------------
9102       double precision function scalar(u,v)
9103 !DIR$ INLINEALWAYS scalar
9104 #ifndef OSF
9105 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9106 #endif
9107       implicit none
9108       double precision u(3),v(3)
9109 cd      double precision sc
9110 cd      integer i
9111 cd      sc=0.0d0
9112 cd      do i=1,3
9113 cd        sc=sc+u(i)*v(i)
9114 cd      enddo
9115 cd      scalar=sc
9116
9117       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9118       return
9119       end
9120 crc-------------------------------------------------
9121       SUBROUTINE MATVEC2(A1,V1,V2)
9122 !DIR$ INLINEALWAYS MATVEC2
9123 #ifndef OSF
9124 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9125 #endif
9126       implicit real*8 (a-h,o-z)
9127       include 'DIMENSIONS'
9128       DIMENSION A1(2,2),V1(2),V2(2)
9129 c      DO 1 I=1,2
9130 c        VI=0.0
9131 c        DO 3 K=1,2
9132 c    3     VI=VI+A1(I,K)*V1(K)
9133 c        Vaux(I)=VI
9134 c    1 CONTINUE
9135
9136       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9137       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9138
9139       v2(1)=vaux1
9140       v2(2)=vaux2
9141       END
9142 C---------------------------------------
9143       SUBROUTINE MATMAT2(A1,A2,A3)
9144 #ifndef OSF
9145 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9146 #endif
9147       implicit real*8 (a-h,o-z)
9148       include 'DIMENSIONS'
9149       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9150 c      DIMENSION AI3(2,2)
9151 c        DO  J=1,2
9152 c          A3IJ=0.0
9153 c          DO K=1,2
9154 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9155 c          enddo
9156 c          A3(I,J)=A3IJ
9157 c       enddo
9158 c      enddo
9159
9160       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9161       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9162       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9163       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9164
9165       A3(1,1)=AI3_11
9166       A3(2,1)=AI3_21
9167       A3(1,2)=AI3_12
9168       A3(2,2)=AI3_22
9169       END
9170
9171 c-------------------------------------------------------------------------
9172       double precision function scalar2(u,v)
9173 !DIR$ INLINEALWAYS scalar2
9174       implicit none
9175       double precision u(2),v(2)
9176       double precision sc
9177       integer i
9178       scalar2=u(1)*v(1)+u(2)*v(2)
9179       return
9180       end
9181
9182 C-----------------------------------------------------------------------------
9183
9184       subroutine transpose2(a,at)
9185 !DIR$ INLINEALWAYS transpose2
9186 #ifndef OSF
9187 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9188 #endif
9189       implicit none
9190       double precision a(2,2),at(2,2)
9191       at(1,1)=a(1,1)
9192       at(1,2)=a(2,1)
9193       at(2,1)=a(1,2)
9194       at(2,2)=a(2,2)
9195       return
9196       end
9197 c--------------------------------------------------------------------------
9198       subroutine transpose(n,a,at)
9199       implicit none
9200       integer n,i,j
9201       double precision a(n,n),at(n,n)
9202       do i=1,n
9203         do j=1,n
9204           at(j,i)=a(i,j)
9205         enddo
9206       enddo
9207       return
9208       end
9209 C---------------------------------------------------------------------------
9210       subroutine prodmat3(a1,a2,kk,transp,prod)
9211 !DIR$ INLINEALWAYS prodmat3
9212 #ifndef OSF
9213 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9214 #endif
9215       implicit none
9216       integer i,j
9217       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9218       logical transp
9219 crc      double precision auxmat(2,2),prod_(2,2)
9220
9221       if (transp) then
9222 crc        call transpose2(kk(1,1),auxmat(1,1))
9223 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9224 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9225
9226            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9227      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9228            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9229      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9230            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9231      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9232            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9233      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9234
9235       else
9236 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9237 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9238
9239            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9240      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9241            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9242      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9243            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9244      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9245            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9246      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9247
9248       endif
9249 c      call transpose2(a2(1,1),a2t(1,1))
9250
9251 crc      print *,transp
9252 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9253 crc      print *,((prod(i,j),i=1,2),j=1,2)
9254
9255       return
9256       end
9257