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 #ifdef DEBUG
 714       write (iout,*) "gloc_sc before reduce"
 715       do i=1,nres
 716        do j=1,1
 717         write (iout,*) i,j,gloc_sc(j,i,icg)
 718        enddo
 719       enddo
 720 #endif
 721         do i=1,nres
 722          do j=1,3
 723           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 724          enddo
 725         enddo
 726         time00=MPI_Wtime()
 727         call MPI_Barrier(FG_COMM,IERR)
 728         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 729         time00=MPI_Wtime()
 730         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 731      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 732         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         time_reduce=time_reduce+MPI_Wtime()-time00
 737         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         time_reduce=time_reduce+MPI_Wtime()-time00
 740 #ifdef DEBUG
 741       write (iout,*) "gloc_sc after reduce"
 742       do i=1,nres
 743        do j=1,1
 744         write (iout,*) i,j,gloc_sc(j,i,icg)
 745        enddo
 746       enddo
 747 #endif
 748 #ifdef DEBUG
 749       write (iout,*) "gloc after reduce"
 750       do i=1,4*nres
 751         write (iout,*) i,gloc(i,icg)
 752       enddo
 753 #endif
 754       endif
 755 #endif
 756       if (gnorm_check) then
 757 c
 758 c Compute the maximum elements of the gradient
 759 c
 760       gvdwc_max=0.0d0
 761       gvdwc_scp_max=0.0d0
 762       gelc_max=0.0d0
 763       gvdwpp_max=0.0d0
 764       gradb_max=0.0d0
 765       ghpbc_max=0.0d0
 766       gradcorr_max=0.0d0
 767       gel_loc_max=0.0d0
 768       gcorr3_turn_max=0.0d0
 769       gcorr4_turn_max=0.0d0
 770       gradcorr5_max=0.0d0
 771       gradcorr6_max=0.0d0
 772       gcorr6_turn_max=0.0d0
 773       gsccorc_max=0.0d0
 774       gscloc_max=0.0d0
 775       gvdwx_max=0.0d0
 776       gradx_scp_max=0.0d0
 777       ghpbx_max=0.0d0
 778       gradxorr_max=0.0d0
 779       gsccorx_max=0.0d0
 780       gsclocx_max=0.0d0
 781       do i=1,nct
 782         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 783         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 784         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 785         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 786      &   gvdwc_scp_max=gvdwc_scp_norm
 787         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 788         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 789         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 790         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 791         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 792         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 793         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 794         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 795         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 796         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 797         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 798         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 799         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 800      &    gcorr3_turn(1,i)))
 801         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 802      &    gcorr3_turn_max=gcorr3_turn_norm
 803         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 804      &    gcorr4_turn(1,i)))
 805         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 806      &    gcorr4_turn_max=gcorr4_turn_norm
 807         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 808         if (gradcorr5_norm.gt.gradcorr5_max)
 809      &    gradcorr5_max=gradcorr5_norm
 810         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 811         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 812         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 813      &    gcorr6_turn(1,i)))
 814         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 815      &    gcorr6_turn_max=gcorr6_turn_norm
 816         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 817         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 818         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 819         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 820         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 821         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 822         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 823         if (gradx_scp_norm.gt.gradx_scp_max)
 824      &    gradx_scp_max=gradx_scp_norm
 825         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 826         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 827         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 828         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 829         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 830         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 831         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 832         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 833       enddo
 834       if (gradout) then
 835 #ifdef AIX
 836         open(istat,file=statname,position="append")
 837 #else
 838         open(istat,file=statname,access="append")
 839 #endif
 840         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 841      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 842      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 843      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 844      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 845      &     gsccorx_max,gsclocx_max
 846         close(istat)
 847         if (gvdwc_max.gt.1.0d4) then
 848           write (iout,*) "gvdwc gvdwx gradb gradbx"
 849           do i=nnt,nct
 850             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 851      &        gradb(j,i),gradbx(j,i),j=1,3)
 852           enddo
 853           call pdbout(0.0d0,'cipiszcze',iout)
 854           call flush(iout)
 855         endif
 856       endif
 857       endif
 858 #ifdef DEBUG
 859       write (iout,*) "gradc gradx gloc"
 860       do i=1,nres
 861         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 862      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 863       enddo
 864 #endif
 865 #ifdef TIMING
 866       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 867 #endif
 868       return
 869       end
 870 c-------------------------------------------------------------------------------
 871       subroutine rescale_weights(t_bath)
 872       implicit real*8 (a-h,o-z)
 873       include 'DIMENSIONS'
 874       include 'COMMON.IOUNITS'
 875       include 'COMMON.FFIELD'
 876       include 'COMMON.SBRIDGE'
 877       double precision kfac /2.4d0/
 878       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 879 c      facT=temp0/t_bath
 880 c      facT=2*temp0/(t_bath+temp0)
 881       if (rescale_mode.eq.0) then
 882         facT=1.0d0
 883         facT2=1.0d0
 884         facT3=1.0d0
 885         facT4=1.0d0
 886         facT5=1.0d0
 887       else if (rescale_mode.eq.1) then
 888         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 889         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 890         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 891         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 892         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 893       else if (rescale_mode.eq.2) then
 894         x=t_bath/temp0
 895         x2=x*x
 896         x3=x2*x
 897         x4=x3*x
 898         x5=x4*x
 899         facT=licznik/dlog(dexp(x)+dexp(-x))
 900         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 901         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 902         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 903         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 904       else
 905         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 906         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 907 #ifdef MPI
 908        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 909 #endif
 910        stop 555
 911       endif
 912       welec=weights(3)*fact
 913       wcorr=weights(4)*fact3
 914       wcorr5=weights(5)*fact4
 915       wcorr6=weights(6)*fact5
 916       wel_loc=weights(7)*fact2
 917       wturn3=weights(8)*fact2
 918       wturn4=weights(9)*fact3
 919       wturn6=weights(10)*fact5
 920       wtor=weights(13)*fact
 921       wtor_d=weights(14)*fact2
 922       wsccor=weights(21)*fact
 923
 924       return
 925       end
 926 C------------------------------------------------------------------------
 927       subroutine enerprint(energia)
 928       implicit real*8 (a-h,o-z)
 929       include 'DIMENSIONS'
 930       include 'COMMON.IOUNITS'
 931       include 'COMMON.FFIELD'
 932       include 'COMMON.SBRIDGE'
 933       include 'COMMON.MD'
 934       double precision energia(0:n_ene)
 935       etot=energia(0)
 936       evdw=energia(1)
 937       evdw2=energia(2)
 938 #ifdef SCP14
 939       evdw2=energia(2)+energia(18)
 940 #else
 941       evdw2=energia(2)
 942 #endif
 943       ees=energia(3)
 944 #ifdef SPLITELE
 945       evdw1=energia(16)
 946 #endif
 947       ecorr=energia(4)
 948       ecorr5=energia(5)
 949       ecorr6=energia(6)
 950       eel_loc=energia(7)
 951       eello_turn3=energia(8)
 952       eello_turn4=energia(9)
 953       eello_turn6=energia(10)
 954       ebe=energia(11)
 955       escloc=energia(12)
 956       etors=energia(13)
 957       etors_d=energia(14)
 958       ehpb=energia(15)
 959       edihcnstr=energia(19)
 960       estr=energia(17)
 961       Uconst=energia(20)
 962       esccor=energia(21)
 963 #ifdef SPLITELE
 964       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 965      &  estr,wbond,ebe,wang,
 966      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 967      &  ecorr,wcorr,
 968      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 969      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 970      &  edihcnstr,ebr*nss,
 971      &  Uconst,etot
 972    10 format (/'Virtual-chain energies:'//
 973      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 974      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 975      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 976      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 977      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 978      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 979      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 980      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 981      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 982      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 983      & ' (SS bridges & dist. cnstr.)'/
 984      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 985      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 986      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 987      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 988      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 989      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 990      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 991      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 992      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 993      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 994      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 995      & 'ETOT=  ',1pE16.6,' (total)')
 996 #else
 997       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 998      &  estr,wbond,ebe,wang,
 999      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1000      &  ecorr,wcorr,
1001      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1002      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1003      &  ebr*nss,Uconst,etot
1004    10 format (/'Virtual-chain energies:'//
1005      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1006      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1007      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1008      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1009      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1010      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1011      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1012      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1013      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1014      & ' (SS bridges & dist. cnstr.)'/
1015      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1016      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1017      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1018      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1019      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1020      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1021      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1022      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1023      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1024      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1025      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1026      & 'ETOT=  ',1pE16.6,' (total)')
1027 #endif
1028       return
1029       end
1030 C-----------------------------------------------------------------------
1031       subroutine elj(evdw)
1032 C
1033 C This subroutine calculates the interaction energy of nonbonded side chains
1034 C assuming the LJ potential of interaction.
1035 C
1036       implicit real*8 (a-h,o-z)
1037       include 'DIMENSIONS'
1038       parameter (accur=1.0d-10)
1039       include 'COMMON.GEO'
1040       include 'COMMON.VAR'
1041       include 'COMMON.LOCAL'
1042       include 'COMMON.CHAIN'
1043       include 'COMMON.DERIV'
1044       include 'COMMON.INTERACT'
1045       include 'COMMON.TORSION'
1046       include 'COMMON.SBRIDGE'
1047       include 'COMMON.NAMES'
1048       include 'COMMON.IOUNITS'
1049       include 'COMMON.CONTACTS'
1050       dimension gg(3)
1051 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1052       evdw=0.0D0
1053       do i=iatsc_s,iatsc_e
1054         itypi=iabs(itype(i))
1055         if (itypi.eq.ntyp1) cycle
1056         itypi1=iabs(itype(i+1))
1057         xi=c(1,nres+i)
1058         yi=c(2,nres+i)
1059         zi=c(3,nres+i)
1060 C Change 12/1/95
1061         num_conti=0
1062 C
1063 C Calculate SC interaction energy.
1064 C
1065         do iint=1,nint_gr(i)
1066 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1067 cd   &                  'iend=',iend(i,iint)
1068           do j=istart(i,iint),iend(i,iint)
1069             itypj=iabs(itype(j))
1070             if (itypj.eq.ntyp1) cycle
1071             xj=c(1,nres+j)-xi
1072             yj=c(2,nres+j)-yi
1073             zj=c(3,nres+j)-zi
1074 C Change 12/1/95 to calculate four-body interactions
1075             rij=xj*xj+yj*yj+zj*zj
1076             rrij=1.0D0/rij
1077 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1078             eps0ij=eps(itypi,itypj)
1079             fac=rrij**expon2
1080             e1=fac*fac*aa(itypi,itypj)
1081             e2=fac*bb(itypi,itypj)
1082             evdwij=e1+e2
1083 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1084 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1085 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1086 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1087 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1088 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1089             evdw=evdw+evdwij
1090 C
1091 C Calculate the components of the gradient in DC and X
1092 C
1093             fac=-rrij*(e1+evdwij)
1094             gg(1)=xj*fac
1095             gg(2)=yj*fac
1096             gg(3)=zj*fac
1097             do k=1,3
1098               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1099               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1100               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1101               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1102             enddo
1103 cgrad            do k=i,j-1
1104 cgrad              do l=1,3
1105 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1106 cgrad              enddo
1107 cgrad            enddo
1108 C
1109 C 12/1/95, revised on 5/20/97
1110 C
1111 C Calculate the contact function. The ith column of the array JCONT will
1112 C contain the numbers of atoms that make contacts with the atom I (of numbers
1113 C greater than I). The arrays FACONT and GACONT will contain the values of
1114 C the contact function and its derivative.
1115 C
1116 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1117 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1118 C Uncomment next line, if the correlation interactions are contact function only
1119             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1120               rij=dsqrt(rij)
1121               sigij=sigma(itypi,itypj)
1122               r0ij=rs0(itypi,itypj)
1123 C
1124 C Check whether the SC's are not too far to make a contact.
1125 C
1126               rcut=1.5d0*r0ij
1127               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1128 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1129 C
1130               if (fcont.gt.0.0D0) then
1131 C If the SC-SC distance if close to sigma, apply spline.
1132 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1133 cAdam &             fcont1,fprimcont1)
1134 cAdam           fcont1=1.0d0-fcont1
1135 cAdam           if (fcont1.gt.0.0d0) then
1136 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1137 cAdam             fcont=fcont*fcont1
1138 cAdam           endif
1139 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1140 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1141 cga             do k=1,3
1142 cga               gg(k)=gg(k)*eps0ij
1143 cga             enddo
1144 cga             eps0ij=-evdwij*eps0ij
1145 C Uncomment for AL's type of SC correlation interactions.
1146 cadam           eps0ij=-evdwij
1147                 num_conti=num_conti+1
1148                 jcont(num_conti,i)=j
1149                 facont(num_conti,i)=fcont*eps0ij
1150                 fprimcont=eps0ij*fprimcont/rij
1151                 fcont=expon*fcont
1152 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1153 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1154 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1155 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1156                 gacont(1,num_conti,i)=-fprimcont*xj
1157                 gacont(2,num_conti,i)=-fprimcont*yj
1158                 gacont(3,num_conti,i)=-fprimcont*zj
1159 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1160 cd              write (iout,'(2i3,3f10.5)')
1161 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1162               endif
1163             endif
1164           enddo      ! j
1165         enddo        ! iint
1166 C Change 12/1/95
1167         num_cont(i)=num_conti
1168       enddo          ! i
1169       do i=1,nct
1170         do j=1,3
1171           gvdwc(j,i)=expon*gvdwc(j,i)
1172           gvdwx(j,i)=expon*gvdwx(j,i)
1173         enddo
1174       enddo
1175 C******************************************************************************
1176 C
1177 C                              N O T E !!!
1178 C
1179 C To save time, the factor of EXPON has been extracted from ALL components
1180 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1181 C use!
1182 C
1183 C******************************************************************************
1184       return
1185       end
1186 C-----------------------------------------------------------------------------
1187       subroutine eljk(evdw)
1188 C
1189 C This subroutine calculates the interaction energy of nonbonded side chains
1190 C assuming the LJK potential of interaction.
1191 C
1192       implicit real*8 (a-h,o-z)
1193       include 'DIMENSIONS'
1194       include 'COMMON.GEO'
1195       include 'COMMON.VAR'
1196       include 'COMMON.LOCAL'
1197       include 'COMMON.CHAIN'
1198       include 'COMMON.DERIV'
1199       include 'COMMON.INTERACT'
1200       include 'COMMON.IOUNITS'
1201       include 'COMMON.NAMES'
1202       dimension gg(3)
1203       logical scheck
1204 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1205       evdw=0.0D0
1206       do i=iatsc_s,iatsc_e
1207         itypi=iabs(itype(i))
1208         if (itypi.eq.ntyp1) cycle
1209         itypi1=iabs(itype(i+1))
1210         xi=c(1,nres+i)
1211         yi=c(2,nres+i)
1212         zi=c(3,nres+i)
1213 C
1214 C Calculate SC interaction energy.
1215 C
1216         do iint=1,nint_gr(i)
1217           do j=istart(i,iint),iend(i,iint)
1218             itypj=iabs(itype(j))
1219             if (itypj.eq.ntyp1) cycle
1220             xj=c(1,nres+j)-xi
1221             yj=c(2,nres+j)-yi
1222             zj=c(3,nres+j)-zi
1223             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1224             fac_augm=rrij**expon
1225             e_augm=augm(itypi,itypj)*fac_augm
1226             r_inv_ij=dsqrt(rrij)
1227             rij=1.0D0/r_inv_ij
1228             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1229             fac=r_shift_inv**expon
1230             e1=fac*fac*aa(itypi,itypj)
1231             e2=fac*bb(itypi,itypj)
1232             evdwij=e_augm+e1+e2
1233 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1234 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1235 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1236 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1237 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1238 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1239 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1240             evdw=evdw+evdwij
1241 C
1242 C Calculate the components of the gradient in DC and X
1243 C
1244             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1245             gg(1)=xj*fac
1246             gg(2)=yj*fac
1247             gg(3)=zj*fac
1248             do k=1,3
1249               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1250               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1251               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1252               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1253             enddo
1254 cgrad            do k=i,j-1
1255 cgrad              do l=1,3
1256 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1257 cgrad              enddo
1258 cgrad            enddo
1259           enddo      ! j
1260         enddo        ! iint
1261       enddo          ! i
1262       do i=1,nct
1263         do j=1,3
1264           gvdwc(j,i)=expon*gvdwc(j,i)
1265           gvdwx(j,i)=expon*gvdwx(j,i)
1266         enddo
1267       enddo
1268       return
1269       end
1270 C-----------------------------------------------------------------------------
1271       subroutine ebp(evdw)
1272 C
1273 C This subroutine calculates the interaction energy of nonbonded side chains
1274 C assuming the Berne-Pechukas potential of interaction.
1275 C
1276       implicit real*8 (a-h,o-z)
1277       include 'DIMENSIONS'
1278       include 'COMMON.GEO'
1279       include 'COMMON.VAR'
1280       include 'COMMON.LOCAL'
1281       include 'COMMON.CHAIN'
1282       include 'COMMON.DERIV'
1283       include 'COMMON.NAMES'
1284       include 'COMMON.INTERACT'
1285       include 'COMMON.IOUNITS'
1286       include 'COMMON.CALC'
1287       common /srutu/ icall
1288 c     double precision rrsave(maxdim)
1289       logical lprn
1290       evdw=0.0D0
1291 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1292       evdw=0.0D0
1293 c     if (icall.eq.0) then
1294 c       lprn=.true.
1295 c     else
1296         lprn=.false.
1297 c     endif
1298       ind=0
1299       do i=iatsc_s,iatsc_e
1300         itypi=iabs(itype(i))
1301         if (itypi.eq.ntyp1) cycle
1302         itypi1=iabs(itype(i+1))
1303         xi=c(1,nres+i)
1304         yi=c(2,nres+i)
1305         zi=c(3,nres+i)
1306         dxi=dc_norm(1,nres+i)
1307         dyi=dc_norm(2,nres+i)
1308         dzi=dc_norm(3,nres+i)
1309 c        dsci_inv=dsc_inv(itypi)
1310         dsci_inv=vbld_inv(i+nres)
1311 C
1312 C Calculate SC interaction energy.
1313 C
1314         do iint=1,nint_gr(i)
1315           do j=istart(i,iint),iend(i,iint)
1316             ind=ind+1
1317             itypj=iabs(itype(j))
1318             if (itypj.eq.ntyp1) cycle
1319 c            dscj_inv=dsc_inv(itypj)
1320             dscj_inv=vbld_inv(j+nres)
1321             chi1=chi(itypi,itypj)
1322             chi2=chi(itypj,itypi)
1323             chi12=chi1*chi2
1324             chip1=chip(itypi)
1325             chip2=chip(itypj)
1326             chip12=chip1*chip2
1327             alf1=alp(itypi)
1328             alf2=alp(itypj)
1329             alf12=0.5D0*(alf1+alf2)
1330 C For diagnostics only!!!
1331 c           chi1=0.0D0
1332 c           chi2=0.0D0
1333 c           chi12=0.0D0
1334 c           chip1=0.0D0
1335 c           chip2=0.0D0
1336 c           chip12=0.0D0
1337 c           alf1=0.0D0
1338 c           alf2=0.0D0
1339 c           alf12=0.0D0
1340             xj=c(1,nres+j)-xi
1341             yj=c(2,nres+j)-yi
1342             zj=c(3,nres+j)-zi
1343             dxj=dc_norm(1,nres+j)
1344             dyj=dc_norm(2,nres+j)
1345             dzj=dc_norm(3,nres+j)
1346             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1347 cd          if (icall.eq.0) then
1348 cd            rrsave(ind)=rrij
1349 cd          else
1350 cd            rrij=rrsave(ind)
1351 cd          endif
1352             rij=dsqrt(rrij)
1353 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1354             call sc_angular
1355 C Calculate whole angle-dependent part of epsilon and contributions
1356 C to its derivatives
1357             fac=(rrij*sigsq)**expon2
1358             e1=fac*fac*aa(itypi,itypj)
1359             e2=fac*bb(itypi,itypj)
1360             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1361             eps2der=evdwij*eps3rt
1362             eps3der=evdwij*eps2rt
1363             evdwij=evdwij*eps2rt*eps3rt
1364             evdw=evdw+evdwij
1365             if (lprn) then
1366             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1367             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1368 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1369 cd     &        restyp(itypi),i,restyp(itypj),j,
1370 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1371 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1372 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1373 cd     &        evdwij
1374             endif
1375 C Calculate gradient components.
1376             e1=e1*eps1*eps2rt**2*eps3rt**2
1377             fac=-expon*(e1+evdwij)
1378             sigder=fac/sigsq
1379             fac=rrij*fac
1380 C Calculate radial part of the gradient
1381             gg(1)=xj*fac
1382             gg(2)=yj*fac
1383             gg(3)=zj*fac
1384 C Calculate the angular part of the gradient and sum add the contributions
1385 C to the appropriate components of the Cartesian gradient.
1386             call sc_grad
1387           enddo      ! j
1388         enddo        ! iint
1389       enddo          ! i
1390 c     stop
1391       return
1392       end
1393 C-----------------------------------------------------------------------------
1394       subroutine egb(evdw)
1395 C
1396 C This subroutine calculates the interaction energy of nonbonded side chains
1397 C assuming the Gay-Berne potential of interaction.
1398 C
1399       implicit real*8 (a-h,o-z)
1400       include 'DIMENSIONS'
1401       include 'COMMON.GEO'
1402       include 'COMMON.VAR'
1403       include 'COMMON.LOCAL'
1404       include 'COMMON.CHAIN'
1405       include 'COMMON.DERIV'
1406       include 'COMMON.NAMES'
1407       include 'COMMON.INTERACT'
1408       include 'COMMON.IOUNITS'
1409       include 'COMMON.CALC'
1410       include 'COMMON.CONTROL'
1411       logical lprn
1412       evdw=0.0D0
1413 ccccc      energy_dec=.false.
1414 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1415       evdw=0.0D0
1416       lprn=.false.
1417 c     if (icall.eq.0) lprn=.false.
1418       ind=0
1419       do i=iatsc_s,iatsc_e
1420         itypi=iabs(itype(i))
1421         if (itypi.eq.ntyp1) cycle
1422         itypi1=iabs(itype(i+1))
1423         xi=c(1,nres+i)
1424         yi=c(2,nres+i)
1425         zi=c(3,nres+i)
1426         dxi=dc_norm(1,nres+i)
1427         dyi=dc_norm(2,nres+i)
1428         dzi=dc_norm(3,nres+i)
1429 c        dsci_inv=dsc_inv(itypi)
1430         dsci_inv=vbld_inv(i+nres)
1431 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1432 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1433 C
1434 C Calculate SC interaction energy.
1435 C
1436         do iint=1,nint_gr(i)
1437           do j=istart(i,iint),iend(i,iint)
1438             ind=ind+1
1439             itypj=iabs(itype(j))
1440             if (itypj.eq.ntyp1) cycle
1441 c            dscj_inv=dsc_inv(itypj)
1442             dscj_inv=vbld_inv(j+nres)
1443 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1444 c     &       1.0d0/vbld(j+nres)
1445 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1446             sig0ij=sigma(itypi,itypj)
1447             chi1=chi(itypi,itypj)
1448             chi2=chi(itypj,itypi)
1449             chi12=chi1*chi2
1450             chip1=chip(itypi)
1451             chip2=chip(itypj)
1452             chip12=chip1*chip2
1453             alf1=alp(itypi)
1454             alf2=alp(itypj)
1455             alf12=0.5D0*(alf1+alf2)
1456 C For diagnostics only!!!
1457 c           chi1=0.0D0
1458 c           chi2=0.0D0
1459 c           chi12=0.0D0
1460 c           chip1=0.0D0
1461 c           chip2=0.0D0
1462 c           chip12=0.0D0
1463 c           alf1=0.0D0
1464 c           alf2=0.0D0
1465 c           alf12=0.0D0
1466             xj=c(1,nres+j)-xi
1467             yj=c(2,nres+j)-yi
1468             zj=c(3,nres+j)-zi
1469             dxj=dc_norm(1,nres+j)
1470             dyj=dc_norm(2,nres+j)
1471             dzj=dc_norm(3,nres+j)
1472 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1473 c            write (iout,*) "j",j," dc_norm",
1474 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1475             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1476             rij=dsqrt(rrij)
1477 C Calculate angle-dependent terms of energy and contributions to their
1478 C derivatives.
1479             call sc_angular
1480             sigsq=1.0D0/sigsq
1481             sig=sig0ij*dsqrt(sigsq)
1482             rij_shift=1.0D0/rij-sig+sig0ij
1483 c for diagnostics; uncomment
1484 c            rij_shift=1.2*sig0ij
1485 C I hate to put IF's in the loops, but here don't have another choice!!!!
1486             if (rij_shift.le.0.0D0) then
1487               evdw=1.0D20
1488 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1489 cd     &        restyp(itypi),i,restyp(itypj),j,
1490 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1491               return
1492             endif
1493             sigder=-sig*sigsq
1494 c---------------------------------------------------------------
1495             rij_shift=1.0D0/rij_shift
1496             fac=rij_shift**expon
1497             e1=fac*fac*aa(itypi,itypj)
1498             e2=fac*bb(itypi,itypj)
1499             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1500             eps2der=evdwij*eps3rt
1501             eps3der=evdwij*eps2rt
1502 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1503 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1504             evdwij=evdwij*eps2rt*eps3rt
1505             evdw=evdw+evdwij
1506             if (lprn) then
1507             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1508             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1509             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1510      &        restyp(itypi),i,restyp(itypj),j,
1511      &        epsi,sigm,chi1,chi2,chip1,chip2,
1512      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1513      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1514      &        evdwij
1515             endif
1516
1517             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1518      &                        'evdw',i,j,evdwij
1519
1520 C Calculate gradient components.
1521             e1=e1*eps1*eps2rt**2*eps3rt**2
1522             fac=-expon*(e1+evdwij)*rij_shift
1523             sigder=fac*sigder
1524             fac=rij*fac
1525 c            fac=0.0d0
1526 C Calculate the radial part of the gradient
1527             gg(1)=xj*fac
1528             gg(2)=yj*fac
1529             gg(3)=zj*fac
1530 C Calculate angular part of the gradient.
1531             call sc_grad
1532           enddo      ! j
1533         enddo        ! iint
1534       enddo          ! i
1535 c      write (iout,*) "Number of loop steps in EGB:",ind
1536 cccc      energy_dec=.false.
1537       return
1538       end
1539 C-----------------------------------------------------------------------------
1540       subroutine egbv(evdw)
1541 C
1542 C This subroutine calculates the interaction energy of nonbonded side chains
1543 C assuming the Gay-Berne-Vorobjev potential of interaction.
1544 C
1545       implicit real*8 (a-h,o-z)
1546       include 'DIMENSIONS'
1547       include 'COMMON.GEO'
1548       include 'COMMON.VAR'
1549       include 'COMMON.LOCAL'
1550       include 'COMMON.CHAIN'
1551       include 'COMMON.DERIV'
1552       include 'COMMON.NAMES'
1553       include 'COMMON.INTERACT'
1554       include 'COMMON.IOUNITS'
1555       include 'COMMON.CALC'
1556       common /srutu/ icall
1557       logical lprn
1558       evdw=0.0D0
1559 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1560       evdw=0.0D0
1561       lprn=.false.
1562 c     if (icall.eq.0) lprn=.true.
1563       ind=0
1564       do i=iatsc_s,iatsc_e
1565         itypi=iabs(itype(i))
1566         if (itypi.eq.ntyp1) cycle
1567         itypi1=iabs(itype(i+1))
1568         xi=c(1,nres+i)
1569         yi=c(2,nres+i)
1570         zi=c(3,nres+i)
1571         dxi=dc_norm(1,nres+i)
1572         dyi=dc_norm(2,nres+i)
1573         dzi=dc_norm(3,nres+i)
1574 c        dsci_inv=dsc_inv(itypi)
1575         dsci_inv=vbld_inv(i+nres)
1576 C
1577 C Calculate SC interaction energy.
1578 C
1579         do iint=1,nint_gr(i)
1580           do j=istart(i,iint),iend(i,iint)
1581             ind=ind+1
1582             itypj=iabs(itype(j))
1583             if (itypj.eq.ntyp1) cycle
1584 c            dscj_inv=dsc_inv(itypj)
1585             dscj_inv=vbld_inv(j+nres)
1586             sig0ij=sigma(itypi,itypj)
1587             r0ij=r0(itypi,itypj)
1588             chi1=chi(itypi,itypj)
1589             chi2=chi(itypj,itypi)
1590             chi12=chi1*chi2
1591             chip1=chip(itypi)
1592             chip2=chip(itypj)
1593             chip12=chip1*chip2
1594             alf1=alp(itypi)
1595             alf2=alp(itypj)
1596             alf12=0.5D0*(alf1+alf2)
1597 C For diagnostics only!!!
1598 c           chi1=0.0D0
1599 c           chi2=0.0D0
1600 c           chi12=0.0D0
1601 c           chip1=0.0D0
1602 c           chip2=0.0D0
1603 c           chip12=0.0D0
1604 c           alf1=0.0D0
1605 c           alf2=0.0D0
1606 c           alf12=0.0D0
1607             xj=c(1,nres+j)-xi
1608             yj=c(2,nres+j)-yi
1609             zj=c(3,nres+j)-zi
1610             dxj=dc_norm(1,nres+j)
1611             dyj=dc_norm(2,nres+j)
1612             dzj=dc_norm(3,nres+j)
1613             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1614             rij=dsqrt(rrij)
1615 C Calculate angle-dependent terms of energy and contributions to their
1616 C derivatives.
1617             call sc_angular
1618             sigsq=1.0D0/sigsq
1619             sig=sig0ij*dsqrt(sigsq)
1620             rij_shift=1.0D0/rij-sig+r0ij
1621 C I hate to put IF's in the loops, but here don't have another choice!!!!
1622             if (rij_shift.le.0.0D0) then
1623               evdw=1.0D20
1624               return
1625             endif
1626             sigder=-sig*sigsq
1627 c---------------------------------------------------------------
1628             rij_shift=1.0D0/rij_shift
1629             fac=rij_shift**expon
1630             e1=fac*fac*aa(itypi,itypj)
1631             e2=fac*bb(itypi,itypj)
1632             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1633             eps2der=evdwij*eps3rt
1634             eps3der=evdwij*eps2rt
1635             fac_augm=rrij**expon
1636             e_augm=augm(itypi,itypj)*fac_augm
1637             evdwij=evdwij*eps2rt*eps3rt
1638             evdw=evdw+evdwij+e_augm
1639             if (lprn) then
1640             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1641             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1642             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1643      &        restyp(itypi),i,restyp(itypj),j,
1644      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1645      &        chi1,chi2,chip1,chip2,
1646      &        eps1,eps2rt**2,eps3rt**2,
1647      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1648      &        evdwij+e_augm
1649             endif
1650 C Calculate gradient components.
1651             e1=e1*eps1*eps2rt**2*eps3rt**2
1652             fac=-expon*(e1+evdwij)*rij_shift
1653             sigder=fac*sigder
1654             fac=rij*fac-2*expon*rrij*e_augm
1655 C Calculate the radial part of the gradient
1656             gg(1)=xj*fac
1657             gg(2)=yj*fac
1658             gg(3)=zj*fac
1659 C Calculate angular part of the gradient.
1660             call sc_grad
1661           enddo      ! j
1662         enddo        ! iint
1663       enddo          ! i
1664       end
1665 C-----------------------------------------------------------------------------
1666       subroutine sc_angular
1667 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1668 C om12. Called by ebp, egb, and egbv.
1669       implicit none
1670       include 'COMMON.CALC'
1671       include 'COMMON.IOUNITS'
1672       erij(1)=xj*rij
1673       erij(2)=yj*rij
1674       erij(3)=zj*rij
1675       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1676       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1677       om12=dxi*dxj+dyi*dyj+dzi*dzj
1678       chiom12=chi12*om12
1679 C Calculate eps1(om12) and its derivative in om12
1680       faceps1=1.0D0-om12*chiom12
1681       faceps1_inv=1.0D0/faceps1
1682       eps1=dsqrt(faceps1_inv)
1683 C Following variable is eps1*deps1/dom12
1684       eps1_om12=faceps1_inv*chiom12
1685 c diagnostics only
1686 c      faceps1_inv=om12
1687 c      eps1=om12
1688 c      eps1_om12=1.0d0
1689 c      write (iout,*) "om12",om12," eps1",eps1
1690 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1691 C and om12.
1692       om1om2=om1*om2
1693       chiom1=chi1*om1
1694       chiom2=chi2*om2
1695       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1696       sigsq=1.0D0-facsig*faceps1_inv
1697       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1698       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1699       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1700 c diagnostics only
1701 c      sigsq=1.0d0
1702 c      sigsq_om1=0.0d0
1703 c      sigsq_om2=0.0d0
1704 c      sigsq_om12=0.0d0
1705 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1706 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1707 c     &    " eps1",eps1
1708 C Calculate eps2 and its derivatives in om1, om2, and om12.
1709       chipom1=chip1*om1
1710       chipom2=chip2*om2
1711       chipom12=chip12*om12
1712       facp=1.0D0-om12*chipom12
1713       facp_inv=1.0D0/facp
1714       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1715 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1716 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1717 C Following variable is the square root of eps2
1718       eps2rt=1.0D0-facp1*facp_inv
1719 C Following three variables are the derivatives of the square root of eps
1720 C in om1, om2, and om12.
1721       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1722       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1723       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1724 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1725       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1726 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1727 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1728 c     &  " eps2rt_om12",eps2rt_om12
1729 C Calculate whole angle-dependent part of epsilon and contributions
1730 C to its derivatives
1731       return
1732       end
1733 C----------------------------------------------------------------------------
1734       subroutine sc_grad
1735       implicit real*8 (a-h,o-z)
1736       include 'DIMENSIONS'
1737       include 'COMMON.CHAIN'
1738       include 'COMMON.DERIV'
1739       include 'COMMON.CALC'
1740       include 'COMMON.IOUNITS'
1741       double precision dcosom1(3),dcosom2(3)
1742       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1743       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1744       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1745      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1746 c diagnostics only
1747 c      eom1=0.0d0
1748 c      eom2=0.0d0
1749 c      eom12=evdwij*eps1_om12
1750 c end diagnostics
1751 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1752 c     &  " sigder",sigder
1753 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1754 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1755       do k=1,3
1756         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1757         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1758       enddo
1759       do k=1,3
1760         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1761       enddo
1762 c      write (iout,*) "gg",(gg(k),k=1,3)
1763       do k=1,3
1764         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1765      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1766      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1767         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1768      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1769      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1770 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1771 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1772 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774       enddo
1775 C
1776 C Calculate the components of the gradient in DC and X
1777 C
1778 cgrad      do k=i,j-1
1779 cgrad        do l=1,3
1780 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1781 cgrad        enddo
1782 cgrad      enddo
1783       do l=1,3
1784         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1785         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1786       enddo
1787       return
1788       end
1789 C-----------------------------------------------------------------------
1790       subroutine e_softsphere(evdw)
1791 C
1792 C This subroutine calculates the interaction energy of nonbonded side chains
1793 C assuming the LJ potential of interaction.
1794 C
1795       implicit real*8 (a-h,o-z)
1796       include 'DIMENSIONS'
1797       parameter (accur=1.0d-10)
1798       include 'COMMON.GEO'
1799       include 'COMMON.VAR'
1800       include 'COMMON.LOCAL'
1801       include 'COMMON.CHAIN'
1802       include 'COMMON.DERIV'
1803       include 'COMMON.INTERACT'
1804       include 'COMMON.TORSION'
1805       include 'COMMON.SBRIDGE'
1806       include 'COMMON.NAMES'
1807       include 'COMMON.IOUNITS'
1808       include 'COMMON.CONTACTS'
1809       dimension gg(3)
1810 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1811       evdw=0.0D0
1812       do i=iatsc_s,iatsc_e
1813         itypi=iabs(itype(i))
1814         if (itypi.eq.ntyp1) cycle
1815         itypi1=iabs(itype(i+1))
1816         xi=c(1,nres+i)
1817         yi=c(2,nres+i)
1818         zi=c(3,nres+i)
1819 C
1820 C Calculate SC interaction energy.
1821 C
1822         do iint=1,nint_gr(i)
1823 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1824 cd   &                  'iend=',iend(i,iint)
1825           do j=istart(i,iint),iend(i,iint)
1826             itypj=iabs(itype(j))
1827             if (itypj.eq.ntyp1) cycle
1828             xj=c(1,nres+j)-xi
1829             yj=c(2,nres+j)-yi
1830             zj=c(3,nres+j)-zi
1831             rij=xj*xj+yj*yj+zj*zj
1832 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1833             r0ij=r0(itypi,itypj)
1834             r0ijsq=r0ij*r0ij
1835 c            print *,i,j,r0ij,dsqrt(rij)
1836             if (rij.lt.r0ijsq) then
1837               evdwij=0.25d0*(rij-r0ijsq)**2
1838               fac=rij-r0ijsq
1839             else
1840               evdwij=0.0d0
1841               fac=0.0d0
1842             endif
1843             evdw=evdw+evdwij
1844 C
1845 C Calculate the components of the gradient in DC and X
1846 C
1847             gg(1)=xj*fac
1848             gg(2)=yj*fac
1849             gg(3)=zj*fac
1850             do k=1,3
1851               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1852               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1853               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1854               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1855             enddo
1856 cgrad            do k=i,j-1
1857 cgrad              do l=1,3
1858 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1859 cgrad              enddo
1860 cgrad            enddo
1861           enddo ! j
1862         enddo ! iint
1863       enddo ! i
1864       return
1865       end
1866 C--------------------------------------------------------------------------
1867       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1868      &              eello_turn4)
1869 C
1870 C Soft-sphere potential of p-p interaction
1871 C
1872       implicit real*8 (a-h,o-z)
1873       include 'DIMENSIONS'
1874       include 'COMMON.CONTROL'
1875       include 'COMMON.IOUNITS'
1876       include 'COMMON.GEO'
1877       include 'COMMON.VAR'
1878       include 'COMMON.LOCAL'
1879       include 'COMMON.CHAIN'
1880       include 'COMMON.DERIV'
1881       include 'COMMON.INTERACT'
1882       include 'COMMON.CONTACTS'
1883       include 'COMMON.TORSION'
1884       include 'COMMON.VECTORS'
1885       include 'COMMON.FFIELD'
1886       dimension ggg(3)
1887 cd      write(iout,*) 'In EELEC_soft_sphere'
1888       ees=0.0D0
1889       evdw1=0.0D0
1890       eel_loc=0.0d0
1891       eello_turn3=0.0d0
1892       eello_turn4=0.0d0
1893       ind=0
1894       do i=iatel_s,iatel_e
1895         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1896         dxi=dc(1,i)
1897         dyi=dc(2,i)
1898         dzi=dc(3,i)
1899         xmedi=c(1,i)+0.5d0*dxi
1900         ymedi=c(2,i)+0.5d0*dyi
1901         zmedi=c(3,i)+0.5d0*dzi
1902         num_conti=0
1903 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1904         do j=ielstart(i),ielend(i)
1905           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1906           ind=ind+1
1907           iteli=itel(i)
1908           itelj=itel(j)
1909           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1910           r0ij=rpp(iteli,itelj)
1911           r0ijsq=r0ij*r0ij
1912           dxj=dc(1,j)
1913           dyj=dc(2,j)
1914           dzj=dc(3,j)
1915           xj=c(1,j)+0.5D0*dxj-xmedi
1916           yj=c(2,j)+0.5D0*dyj-ymedi
1917           zj=c(3,j)+0.5D0*dzj-zmedi
1918           rij=xj*xj+yj*yj+zj*zj
1919           if (rij.lt.r0ijsq) then
1920             evdw1ij=0.25d0*(rij-r0ijsq)**2
1921             fac=rij-r0ijsq
1922           else
1923             evdw1ij=0.0d0
1924             fac=0.0d0
1925           endif
1926           evdw1=evdw1+evdw1ij
1927 C
1928 C Calculate contributions to the Cartesian gradient.
1929 C
1930           ggg(1)=fac*xj
1931           ggg(2)=fac*yj
1932           ggg(3)=fac*zj
1933           do k=1,3
1934             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1935             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1936           enddo
1937 *
1938 * Loop over residues i+1 thru j-1.
1939 *
1940 cgrad          do k=i+1,j-1
1941 cgrad            do l=1,3
1942 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1943 cgrad            enddo
1944 cgrad          enddo
1945         enddo ! j
1946       enddo   ! i
1947 cgrad      do i=nnt,nct-1
1948 cgrad        do k=1,3
1949 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1950 cgrad        enddo
1951 cgrad        do j=i+1,nct-1
1952 cgrad          do k=1,3
1953 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1954 cgrad          enddo
1955 cgrad        enddo
1956 cgrad      enddo
1957       return
1958       end
1959 c------------------------------------------------------------------------------
1960       subroutine vec_and_deriv
1961       implicit real*8 (a-h,o-z)
1962       include 'DIMENSIONS'
1963 #ifdef MPI
1964       include 'mpif.h'
1965 #endif
1966       include 'COMMON.IOUNITS'
1967       include 'COMMON.GEO'
1968       include 'COMMON.VAR'
1969       include 'COMMON.LOCAL'
1970       include 'COMMON.CHAIN'
1971       include 'COMMON.VECTORS'
1972       include 'COMMON.SETUP'
1973       include 'COMMON.TIME1'
1974       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1975 C Compute the local reference systems. For reference system (i), the
1976 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1977 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1978 #ifdef PARVEC
1979       do i=ivec_start,ivec_end
1980 #else
1981       do i=1,nres-1
1982 #endif
1983           if (i.eq.nres-1) then
1984 C Case of the last full residue
1985 C Compute the Z-axis
1986             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1987             costh=dcos(pi-theta(nres))
1988             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1989             do k=1,3
1990               uz(k,i)=fac*uz(k,i)
1991             enddo
1992 C Compute the derivatives of uz
1993             uzder(1,1,1)= 0.0d0
1994             uzder(2,1,1)=-dc_norm(3,i-1)
1995             uzder(3,1,1)= dc_norm(2,i-1)
1996             uzder(1,2,1)= dc_norm(3,i-1)
1997             uzder(2,2,1)= 0.0d0
1998             uzder(3,2,1)=-dc_norm(1,i-1)
1999             uzder(1,3,1)=-dc_norm(2,i-1)
2000             uzder(2,3,1)= dc_norm(1,i-1)
2001             uzder(3,3,1)= 0.0d0
2002             uzder(1,1,2)= 0.0d0
2003             uzder(2,1,2)= dc_norm(3,i)
2004             uzder(3,1,2)=-dc_norm(2,i)
2005             uzder(1,2,2)=-dc_norm(3,i)
2006             uzder(2,2,2)= 0.0d0
2007             uzder(3,2,2)= dc_norm(1,i)
2008             uzder(1,3,2)= dc_norm(2,i)
2009             uzder(2,3,2)=-dc_norm(1,i)
2010             uzder(3,3,2)= 0.0d0
2011 C Compute the Y-axis
2012             facy=fac
2013             do k=1,3
2014               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2015             enddo
2016 C Compute the derivatives of uy
2017             do j=1,3
2018               do k=1,3
2019                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2020      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2021                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2022               enddo
2023               uyder(j,j,1)=uyder(j,j,1)-costh
2024               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2025             enddo
2026             do j=1,2
2027               do k=1,3
2028                 do l=1,3
2029                   uygrad(l,k,j,i)=uyder(l,k,j)
2030                   uzgrad(l,k,j,i)=uzder(l,k,j)
2031                 enddo
2032               enddo
2033             enddo
2034             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2035             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2036             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2037             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2038           else
2039 C Other residues
2040 C Compute the Z-axis
2041             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2042             costh=dcos(pi-theta(i+2))
2043             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2044             do k=1,3
2045               uz(k,i)=fac*uz(k,i)
2046             enddo
2047 C Compute the derivatives of uz
2048             uzder(1,1,1)= 0.0d0
2049             uzder(2,1,1)=-dc_norm(3,i+1)
2050             uzder(3,1,1)= dc_norm(2,i+1)
2051             uzder(1,2,1)= dc_norm(3,i+1)
2052             uzder(2,2,1)= 0.0d0
2053             uzder(3,2,1)=-dc_norm(1,i+1)
2054             uzder(1,3,1)=-dc_norm(2,i+1)
2055             uzder(2,3,1)= dc_norm(1,i+1)
2056             uzder(3,3,1)= 0.0d0
2057             uzder(1,1,2)= 0.0d0
2058             uzder(2,1,2)= dc_norm(3,i)
2059             uzder(3,1,2)=-dc_norm(2,i)
2060             uzder(1,2,2)=-dc_norm(3,i)
2061             uzder(2,2,2)= 0.0d0
2062             uzder(3,2,2)= dc_norm(1,i)
2063             uzder(1,3,2)= dc_norm(2,i)
2064             uzder(2,3,2)=-dc_norm(1,i)
2065             uzder(3,3,2)= 0.0d0
2066 C Compute the Y-axis
2067             facy=fac
2068             do k=1,3
2069               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2070             enddo
2071 C Compute the derivatives of uy
2072             do j=1,3
2073               do k=1,3
2074                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2075      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2076                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2077               enddo
2078               uyder(j,j,1)=uyder(j,j,1)-costh
2079               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2080             enddo
2081             do j=1,2
2082               do k=1,3
2083                 do l=1,3
2084                   uygrad(l,k,j,i)=uyder(l,k,j)
2085                   uzgrad(l,k,j,i)=uzder(l,k,j)
2086                 enddo
2087               enddo
2088             enddo
2089             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2090             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2091             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2092             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2093           endif
2094       enddo
2095       do i=1,nres-1
2096         vbld_inv_temp(1)=vbld_inv(i+1)
2097         if (i.lt.nres-1) then
2098           vbld_inv_temp(2)=vbld_inv(i+2)
2099           else
2100           vbld_inv_temp(2)=vbld_inv(i)
2101           endif
2102         do j=1,2
2103           do k=1,3
2104             do l=1,3
2105               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2106               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2107             enddo
2108           enddo
2109         enddo
2110       enddo
2111 #if defined(PARVEC) && defined(MPI)
2112       if (nfgtasks1.gt.1) then
2113         time00=MPI_Wtime()
2114 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2115 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2116 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2117         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2118      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2119      &   FG_COMM1,IERR)
2120         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2121      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2122      &   FG_COMM1,IERR)
2123         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2124      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2125      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2126         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2127      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2128      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2129         time_gather=time_gather+MPI_Wtime()-time00
2130       endif
2131 c      if (fg_rank.eq.0) then
2132 c        write (iout,*) "Arrays UY and UZ"
2133 c        do i=1,nres-1
2134 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2135 c     &     (uz(k,i),k=1,3)
2136 c        enddo
2137 c      endif
2138 #endif
2139       return
2140       end
2141 C-----------------------------------------------------------------------------
2142       subroutine check_vecgrad
2143       implicit real*8 (a-h,o-z)
2144       include 'DIMENSIONS'
2145       include 'COMMON.IOUNITS'
2146       include 'COMMON.GEO'
2147       include 'COMMON.VAR'
2148       include 'COMMON.LOCAL'
2149       include 'COMMON.CHAIN'
2150       include 'COMMON.VECTORS'
2151       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2152       dimension uyt(3,maxres),uzt(3,maxres)
2153       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2154       double precision delta /1.0d-7/
2155       call vec_and_deriv
2156 cd      do i=1,nres
2157 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2158 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2159 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2160 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2161 cd     &     (dc_norm(if90,i),if90=1,3)
2162 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2163 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2164 cd          write(iout,'(a)')
2165 cd      enddo
2166       do i=1,nres
2167         do j=1,2
2168           do k=1,3
2169             do l=1,3
2170               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2171               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2172             enddo
2173           enddo
2174         enddo
2175       enddo
2176       call vec_and_deriv
2177       do i=1,nres
2178         do j=1,3
2179           uyt(j,i)=uy(j,i)
2180           uzt(j,i)=uz(j,i)
2181         enddo
2182       enddo
2183       do i=1,nres
2184 cd        write (iout,*) 'i=',i
2185         do k=1,3
2186           erij(k)=dc_norm(k,i)
2187         enddo
2188         do j=1,3
2189           do k=1,3
2190             dc_norm(k,i)=erij(k)
2191           enddo
2192           dc_norm(j,i)=dc_norm(j,i)+delta
2193 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2194 c          do k=1,3
2195 c            dc_norm(k,i)=dc_norm(k,i)/fac
2196 c          enddo
2197 c          write (iout,*) (dc_norm(k,i),k=1,3)
2198 c          write (iout,*) (erij(k),k=1,3)
2199           call vec_and_deriv
2200           do k=1,3
2201             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2202             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2203             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2204             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2205           enddo
2206 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2207 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2208 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2209         enddo
2210         do k=1,3
2211           dc_norm(k,i)=erij(k)
2212         enddo
2213 cd        do k=1,3
2214 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2215 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2216 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2217 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2218 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2219 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2220 cd          write (iout,'(a)')
2221 cd        enddo
2222       enddo
2223       return
2224       end
2225 C--------------------------------------------------------------------------
2226       subroutine set_matrices
2227       implicit real*8 (a-h,o-z)
2228       include 'DIMENSIONS'
2229 #ifdef MPI
2230       include "mpif.h"
2231       include "COMMON.SETUP"
2232       integer IERR
2233       integer status(MPI_STATUS_SIZE)
2234 #endif
2235       include 'COMMON.IOUNITS'
2236       include 'COMMON.GEO'
2237       include 'COMMON.VAR'
2238       include 'COMMON.LOCAL'
2239       include 'COMMON.CHAIN'
2240       include 'COMMON.DERIV'
2241       include 'COMMON.INTERACT'
2242       include 'COMMON.CONTACTS'
2243       include 'COMMON.TORSION'
2244       include 'COMMON.VECTORS'
2245       include 'COMMON.FFIELD'
2246       double precision auxvec(2),auxmat(2,2)
2247 C
2248 C Compute the virtual-bond-torsional-angle dependent quantities needed
2249 C to calculate the el-loc multibody terms of various order.
2250 C
2251 c      write(iout,*) 'nphi=',nphi,nres
2252 #ifdef PARMAT
2253       do i=ivec_start+2,ivec_end+2
2254 #else
2255       do i=3,nres+1
2256 #endif
2257 #ifdef NEWCORR
2258         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2259           iti = itortyp(itype(i-2))
2260         else
2261           iti=ntortyp+1
2262         endif
2263 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2264         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2265           iti1 = itortyp(itype(i-1))
2266         else
2267           iti1=ntortyp+1
2268         endif
2269 c        write(iout,*),i
2270         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2271      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2272      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2273         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2274      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2275      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2276 c     &           +bnew1(3,1,iti)*dsin(alpha(i))*cos(beta(i))
2277 c     &*(cos(theta(i)/2.0)
2278         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2279      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2280      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2281 c     &           +bnew2(3,1,iti)*dsin(alpha(i))*dcos(beta(i))
2282 c     &*(cos(theta(i)/2.0)
2283         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2284      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2285      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2286 c        if (ggb1(1,i).eq.0.0d0) then
2287 c        write(iout,*) 'i=',i,ggb1(1,i),
2288 c     &bnew1(1,1,iti)*dcos(theta(i)/2.0d0)/2.0d0,
2289 c     &bnew1(2,1,iti)*dcos(theta(i)),
2290 c     &bnew1(3,1,iti)*dsin(theta(i)/2.0d0)/2.0d0
2291 c        endif
2292         b1(2,i-2)=bnew1(1,2,iti)
2293         gtb1(2,i-2)=0.0
2294         b2(2,i-2)=bnew2(1,2,iti)
2295         gtb2(2,i-2)=0.0
2296         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2297         EE(1,2,i-2)=eeold(1,2,iti)
2298         EE(2,1,i-2)=eeold(2,1,iti)
2299         EE(2,2,i-2)=eeold(2,2,iti)
2300         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2301         gtEE(1,2,i-2)=0.0d0
2302         gtEE(2,2,i-2)=0.0d0
2303         gtEE(2,1,i-2)=0.0d0
2304 c        EE(2,2,iti)=0.0d0
2305 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2306 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2307 c        b1(2,iti)=bnew1(1,2,iti)*dsin(alpha(i))*dsin(beta(i))
2308 c        b2(2,iti)=bnew2(1,2,iti)*dsin(alpha(i))*dsin(beta(i))
2309        b1tilde(1,i-2)=b1(1,i-2)
2310        b1tilde(2,i-2)=-b1(2,i-2)
2311        b2tilde(1,i-2)=b2(1,i-2)
2312        b2tilde(2,i-2)=-b2(2,i-2)
2313 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2314 c       write (iout,*) 'theta=', theta(i-1)
2315        enddo
2316 #ifdef PARMAT
2317       do i=ivec_start+2,ivec_end+2
2318 #else
2319       do i=3,nres+1
2320 #endif
2321 #endif
2322         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2323           iti = itortyp(itype(i-2))
2324         else
2325           iti=ntortyp+1
2326         endif
2327 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2328         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2329           iti1 = itortyp(itype(i-1))
2330         else
2331           iti1=ntortyp+1
2332         endif
2333         if (i .lt. nres+1) then
2334           sin1=dsin(phi(i))
2335           cos1=dcos(phi(i))
2336           sintab(i-2)=sin1
2337           costab(i-2)=cos1
2338           obrot(1,i-2)=cos1
2339           obrot(2,i-2)=sin1
2340           sin2=dsin(2*phi(i))
2341           cos2=dcos(2*phi(i))
2342           sintab2(i-2)=sin2
2343           costab2(i-2)=cos2
2344           obrot2(1,i-2)=cos2
2345           obrot2(2,i-2)=sin2
2346           Ug(1,1,i-2)=-cos1
2347           Ug(1,2,i-2)=-sin1
2348           Ug(2,1,i-2)=-sin1
2349           Ug(2,2,i-2)= cos1
2350           Ug2(1,1,i-2)=-cos2
2351           Ug2(1,2,i-2)=-sin2
2352           Ug2(2,1,i-2)=-sin2
2353           Ug2(2,2,i-2)= cos2
2354         else
2355           costab(i-2)=1.0d0
2356           sintab(i-2)=0.0d0
2357           obrot(1,i-2)=1.0d0
2358           obrot(2,i-2)=0.0d0
2359           obrot2(1,i-2)=0.0d0
2360           obrot2(2,i-2)=0.0d0
2361           Ug(1,1,i-2)=1.0d0
2362           Ug(1,2,i-2)=0.0d0
2363           Ug(2,1,i-2)=0.0d0
2364           Ug(2,2,i-2)=1.0d0
2365           Ug2(1,1,i-2)=0.0d0
2366           Ug2(1,2,i-2)=0.0d0
2367           Ug2(2,1,i-2)=0.0d0
2368           Ug2(2,2,i-2)=0.0d0
2369         endif
2370         if (i .gt. 3 .and. i .lt. nres+1) then
2371           obrot_der(1,i-2)=-sin1
2372           obrot_der(2,i-2)= cos1
2373           Ugder(1,1,i-2)= sin1
2374           Ugder(1,2,i-2)=-cos1
2375           Ugder(2,1,i-2)=-cos1
2376           Ugder(2,2,i-2)=-sin1
2377           dwacos2=cos2+cos2
2378           dwasin2=sin2+sin2
2379           obrot2_der(1,i-2)=-dwasin2
2380           obrot2_der(2,i-2)= dwacos2
2381           Ug2der(1,1,i-2)= dwasin2
2382           Ug2der(1,2,i-2)=-dwacos2
2383           Ug2der(2,1,i-2)=-dwacos2
2384           Ug2der(2,2,i-2)=-dwasin2
2385         else
2386           obrot_der(1,i-2)=0.0d0
2387           obrot_der(2,i-2)=0.0d0
2388           Ugder(1,1,i-2)=0.0d0
2389           Ugder(1,2,i-2)=0.0d0
2390           Ugder(2,1,i-2)=0.0d0
2391           Ugder(2,2,i-2)=0.0d0
2392           obrot2_der(1,i-2)=0.0d0
2393           obrot2_der(2,i-2)=0.0d0
2394           Ug2der(1,1,i-2)=0.0d0
2395           Ug2der(1,2,i-2)=0.0d0
2396           Ug2der(2,1,i-2)=0.0d0
2397           Ug2der(2,2,i-2)=0.0d0
2398         endif
2399 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2400         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2401           iti = itortyp(itype(i-2))
2402         else
2403           iti=ntortyp+1
2404         endif
2405 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2406         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2407           iti1 = itortyp(itype(i-1))
2408         else
2409           iti1=ntortyp+1
2410         endif
2411 cd        write (iout,*) '*******i',i,' iti1',iti
2412 cd        write (iout,*) 'b1',b1(:,iti)
2413 cd        write (iout,*) 'b2',b2(:,iti)
2414 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2415 c        if (i .gt. iatel_s+2) then
2416         if (i .gt. nnt+2) then
2417           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2418 #ifdef NEWCORR
2419           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2420 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2421 #endif
2422 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2423 c     &    EE(1,2,iti),EE(2,2,iti)
2424           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2425           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2426 c          write(iout,*) "Macierz EUG",
2427 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2428 c     &    eug(2,2,i-2)
2429           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2430      &    then
2431           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2432           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2433           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2434           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2435           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2436           endif
2437         else
2438           do k=1,2
2439             Ub2(k,i-2)=0.0d0
2440             Ctobr(k,i-2)=0.0d0
2441             Dtobr2(k,i-2)=0.0d0
2442             do l=1,2
2443               EUg(l,k,i-2)=0.0d0
2444               CUg(l,k,i-2)=0.0d0
2445               DUg(l,k,i-2)=0.0d0
2446               DtUg2(l,k,i-2)=0.0d0
2447             enddo
2448           enddo
2449         endif
2450         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2451         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2452         do k=1,2
2453           muder(k,i-2)=Ub2der(k,i-2)
2454         enddo
2455 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2456         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2457           if (itype(i-1).le.ntyp) then
2458             iti1 = itortyp(itype(i-1))
2459           else
2460             iti1=ntortyp+1
2461           endif
2462         else
2463           iti1=ntortyp+1
2464         endif
2465         do k=1,2
2466           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2467         enddo
2468 #ifdef MUOUT
2469         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2470      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2471      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2472      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2473      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2474      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itortyp(iti))
2475 #endif
2476 cd        write (iout,*) 'mu ',mu(:,i-2)
2477 cd        write (iout,*) 'mu1',mu1(:,i-2)
2478 cd        write (iout,*) 'mu2',mu2(:,i-2)
2479         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2480      &  then
2481         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2482         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2483         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2484         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2485         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2486 C Vectors and matrices dependent on a single virtual-bond dihedral.
2487         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2488         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2489         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2490         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2491         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2492         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2493         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2494         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2495         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2496         endif
2497       enddo
2498 C Matrices dependent on two consecutive virtual-bond dihedrals.
2499 C The order of matrices is from left to right.
2500       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2501      &then
2502 c      do i=max0(ivec_start,2),ivec_end
2503       do i=2,nres-1
2504         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2505         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2506         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2507         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2508         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2509         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2510         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2511         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2512       enddo
2513       endif
2514 #if defined(MPI) && defined(PARMAT)
2515 #ifdef DEBUG
2516 c      if (fg_rank.eq.0) then
2517         write (iout,*) "Arrays UG and UGDER before GATHER"
2518         do i=1,nres-1
2519           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2520      &     ((ug(l,k,i),l=1,2),k=1,2),
2521      &     ((ugder(l,k,i),l=1,2),k=1,2)
2522         enddo
2523         write (iout,*) "Arrays UG2 and UG2DER"
2524         do i=1,nres-1
2525           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2526      &     ((ug2(l,k,i),l=1,2),k=1,2),
2527      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2528         enddo
2529         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2530         do i=1,nres-1
2531           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2532      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2533      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2534         enddo
2535         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2536         do i=1,nres-1
2537           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2538      &     costab(i),sintab(i),costab2(i),sintab2(i)
2539         enddo
2540         write (iout,*) "Array MUDER"
2541         do i=1,nres-1
2542           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2543         enddo
2544 c      endif
2545 #endif
2546       if (nfgtasks.gt.1) then
2547         time00=MPI_Wtime()
2548 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2549 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2550 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2551 #ifdef MATGATHER
2552         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2571      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2572      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2573         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2574      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2575      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2576         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2577      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2578      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2579         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2580      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2581      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2582         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2583      &  then
2584         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2588      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2589      &   FG_COMM1,IERR)
2590         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2591      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2592      &   FG_COMM1,IERR)
2593        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2594      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2597      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2598      &   FG_COMM1,IERR)
2599         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2600      &   ivec_count(fg_rank1),
2601      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2605      &   FG_COMM1,IERR)
2606         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2611      &   FG_COMM1,IERR)
2612         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2614      &   FG_COMM1,IERR)
2615         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2622      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2623      &   FG_COMM1,IERR)
2624         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2625      &   ivec_count(fg_rank1),
2626      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2630      &   FG_COMM1,IERR)
2631        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2636      &   FG_COMM1,IERR)
2637        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2641      &   ivec_count(fg_rank1),
2642      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2643      &   FG_COMM1,IERR)
2644         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2645      &   ivec_count(fg_rank1),
2646      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2647      &   FG_COMM1,IERR)
2648         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2649      &   ivec_count(fg_rank1),
2650      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2651      &   MPI_MAT2,FG_COMM1,IERR)
2652         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2653      &   ivec_count(fg_rank1),
2654      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2655      &   MPI_MAT2,FG_COMM1,IERR)
2656         endif
2657 #else
2658 c Passes matrix info through the ring
2659       isend=fg_rank1
2660       irecv=fg_rank1-1
2661       if (irecv.lt.0) irecv=nfgtasks1-1
2662       iprev=irecv
2663       inext=fg_rank1+1
2664       if (inext.ge.nfgtasks1) inext=0
2665       do i=1,nfgtasks1-1
2666 c        write (iout,*) "isend",isend," irecv",irecv
2667 c        call flush(iout)
2668         lensend=lentyp(isend)
2669         lenrecv=lentyp(irecv)
2670 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2671 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2672 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2673 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2674 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2675 c        write (iout,*) "Gather ROTAT1"
2676 c        call flush(iout)
2677 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2678 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2679 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2680 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2681 c        write (iout,*) "Gather ROTAT2"
2682 c        call flush(iout)
2683         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2684      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2685      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2686      &   iprev,4400+irecv,FG_COMM,status,IERR)
2687 c        write (iout,*) "Gather ROTAT_OLD"
2688 c        call flush(iout)
2689         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2690      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2691      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2692      &   iprev,5500+irecv,FG_COMM,status,IERR)
2693 c        write (iout,*) "Gather PRECOMP11"
2694 c        call flush(iout)
2695         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2696      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2697      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2698      &   iprev,6600+irecv,FG_COMM,status,IERR)
2699 c        write (iout,*) "Gather PRECOMP12"
2700 c        call flush(iout)
2701         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2702      &  then
2703         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2704      &   MPI_ROTAT2(lensend),inext,7700+isend,
2705      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2706      &   iprev,7700+irecv,FG_COMM,status,IERR)
2707 c        write (iout,*) "Gather PRECOMP21"
2708 c        call flush(iout)
2709         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2710      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2711      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2712      &   iprev,8800+irecv,FG_COMM,status,IERR)
2713 c        write (iout,*) "Gather PRECOMP22"
2714 c        call flush(iout)
2715         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2716      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2717      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2718      &   MPI_PRECOMP23(lenrecv),
2719      &   iprev,9900+irecv,FG_COMM,status,IERR)
2720 c        write (iout,*) "Gather PRECOMP23"
2721 c        call flush(iout)
2722         endif
2723         isend=irecv
2724         irecv=irecv-1
2725         if (irecv.lt.0) irecv=nfgtasks1-1
2726       enddo
2727 #endif
2728         time_gather=time_gather+MPI_Wtime()-time00
2729       endif
2730 #ifdef DEBUG
2731 c      if (fg_rank.eq.0) then
2732         write (iout,*) "Arrays UG and UGDER"
2733         do i=1,nres-1
2734           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2735      &     ((ug(l,k,i),l=1,2),k=1,2),
2736      &     ((ugder(l,k,i),l=1,2),k=1,2)
2737         enddo
2738         write (iout,*) "Arrays UG2 and UG2DER"
2739         do i=1,nres-1
2740           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2741      &     ((ug2(l,k,i),l=1,2),k=1,2),
2742      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2743         enddo
2744         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2745         do i=1,nres-1
2746           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2747      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2748      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2749         enddo
2750         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2751         do i=1,nres-1
2752           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2753      &     costab(i),sintab(i),costab2(i),sintab2(i)
2754         enddo
2755         write (iout,*) "Array MUDER"
2756         do i=1,nres-1
2757           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2758         enddo
2759 c      endif
2760 #endif
2761 #endif
2762 cd      do i=1,nres
2763 cd        iti = itortyp(itype(i))
2764 cd        write (iout,*) i
2765 cd        do j=1,2
2766 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2767 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2768 cd        enddo
2769 cd      enddo
2770       return
2771       end
2772 C--------------------------------------------------------------------------
2773       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2774 C
2775 C This subroutine calculates the average interaction energy and its gradient
2776 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2777 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2778 C The potential depends both on the distance of peptide-group centers and on
2779 C the orientation of the CA-CA virtual bonds.
2780 C
2781       implicit real*8 (a-h,o-z)
2782 #ifdef MPI
2783       include 'mpif.h'
2784 #endif
2785       include 'DIMENSIONS'
2786       include 'COMMON.CONTROL'
2787       include 'COMMON.SETUP'
2788       include 'COMMON.IOUNITS'
2789       include 'COMMON.GEO'
2790       include 'COMMON.VAR'
2791       include 'COMMON.LOCAL'
2792       include 'COMMON.CHAIN'
2793       include 'COMMON.DERIV'
2794       include 'COMMON.INTERACT'
2795       include 'COMMON.CONTACTS'
2796       include 'COMMON.TORSION'
2797       include 'COMMON.VECTORS'
2798       include 'COMMON.FFIELD'
2799       include 'COMMON.TIME1'
2800       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2801      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2802       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2803      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2804       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2805      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2806      &    num_conti,j1,j2
2807 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2808 #ifdef MOMENT
2809       double precision scal_el /1.0d0/
2810 #else
2811       double precision scal_el /0.5d0/
2812 #endif
2813 C 12/13/98
2814 C 13-go grudnia roku pamietnego...
2815       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2816      &                   0.0d0,1.0d0,0.0d0,
2817      &                   0.0d0,0.0d0,1.0d0/
2818 cd      write(iout,*) 'In EELEC'
2819 cd      do i=1,nloctyp
2820 cd        write(iout,*) 'Type',i
2821 cd        write(iout,*) 'B1',B1(:,i)
2822 cd        write(iout,*) 'B2',B2(:,i)
2823 cd        write(iout,*) 'CC',CC(:,:,i)
2824 cd        write(iout,*) 'DD',DD(:,:,i)
2825 cd        write(iout,*) 'EE',EE(:,:,i)
2826 cd      enddo
2827 cd      call check_vecgrad
2828 cd      stop
2829       if (icheckgrad.eq.1) then
2830         do i=1,nres-1
2831           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2832           do k=1,3
2833             dc_norm(k,i)=dc(k,i)*fac
2834           enddo
2835 c          write (iout,*) 'i',i,' fac',fac
2836         enddo
2837       endif
2838       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2839      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2840      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2841 c        call vec_and_deriv
2842 #ifdef TIMING
2843         time01=MPI_Wtime()
2844 #endif
2845         call set_matrices
2846 #ifdef TIMING
2847         time_mat=time_mat+MPI_Wtime()-time01
2848 #endif
2849       endif
2850 cd      do i=1,nres-1
2851 cd        write (iout,*) 'i=',i
2852 cd        do k=1,3
2853 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2854 cd        enddo
2855 cd        do k=1,3
2856 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2857 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2858 cd        enddo
2859 cd      enddo
2860       t_eelecij=0.0d0
2861       ees=0.0D0
2862       evdw1=0.0D0
2863       eel_loc=0.0d0
2864       eello_turn3=0.0d0
2865       eello_turn4=0.0d0
2866       ind=0
2867       do i=1,nres
2868         num_cont_hb(i)=0
2869       enddo
2870 cd      print '(a)','Enter EELEC'
2871 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2872       do i=1,nres
2873         gel_loc_loc(i)=0.0d0
2874         gcorr_loc(i)=0.0d0
2875       enddo
2876 c
2877 c
2878 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2879 C
2880 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2881 C
2882       do i=iturn3_start,iturn3_end
2883         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2884      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2885         dxi=dc(1,i)
2886         dyi=dc(2,i)
2887         dzi=dc(3,i)
2888         dx_normi=dc_norm(1,i)
2889         dy_normi=dc_norm(2,i)
2890         dz_normi=dc_norm(3,i)
2891         xmedi=c(1,i)+0.5d0*dxi
2892         ymedi=c(2,i)+0.5d0*dyi
2893         zmedi=c(3,i)+0.5d0*dzi
2894         num_conti=0
2895         call eelecij(i,i+2,ees,evdw1,eel_loc)
2896         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2897         num_cont_hb(i)=num_conti
2898       enddo
2899       do i=iturn4_start,iturn4_end
2900         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2901      &    .or. itype(i+3).eq.ntyp1
2902      &    .or. itype(i+4).eq.ntyp1) cycle
2903         dxi=dc(1,i)
2904         dyi=dc(2,i)
2905         dzi=dc(3,i)
2906         dx_normi=dc_norm(1,i)
2907         dy_normi=dc_norm(2,i)
2908         dz_normi=dc_norm(3,i)
2909         xmedi=c(1,i)+0.5d0*dxi
2910         ymedi=c(2,i)+0.5d0*dyi
2911         zmedi=c(3,i)+0.5d0*dzi
2912         num_conti=num_cont_hb(i)
2913 c        write(iout,*) "JESTEM W PETLI"
2914         call eelecij(i,i+3,ees,evdw1,eel_loc)
2915         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2916      &   call eturn4(i,eello_turn4)
2917         num_cont_hb(i)=num_conti
2918       enddo   ! i
2919 c
2920 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2921 c
2922       do i=iatel_s,iatel_e
2923 c       do i=7,7
2924         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2925         dxi=dc(1,i)
2926         dyi=dc(2,i)
2927         dzi=dc(3,i)
2928         dx_normi=dc_norm(1,i)
2929         dy_normi=dc_norm(2,i)
2930         dz_normi=dc_norm(3,i)
2931         xmedi=c(1,i)+0.5d0*dxi
2932         ymedi=c(2,i)+0.5d0*dyi
2933         zmedi=c(3,i)+0.5d0*dzi
2934 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2935         num_conti=num_cont_hb(i)
2936         do j=ielstart(i),ielend(i)
2937 c         do j=13,13
2938 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2939           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2940           call eelecij(i,j,ees,evdw1,eel_loc)
2941         enddo ! j
2942         num_cont_hb(i)=num_conti
2943       enddo   ! i
2944 c      write (iout,*) "Number of loop steps in EELEC:",ind
2945 cd      do i=1,nres
2946 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2947 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2948 cd      enddo
2949 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2950 ccc      eel_loc=eel_loc+eello_turn3
2951 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2952       return
2953       end
2954 C-------------------------------------------------------------------------------
2955       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2956       implicit real*8 (a-h,o-z)
2957       include 'DIMENSIONS'
2958 #ifdef MPI
2959       include "mpif.h"
2960 #endif
2961       include 'COMMON.CONTROL'
2962       include 'COMMON.IOUNITS'
2963       include 'COMMON.GEO'
2964       include 'COMMON.VAR'
2965       include 'COMMON.LOCAL'
2966       include 'COMMON.CHAIN'
2967       include 'COMMON.DERIV'
2968       include 'COMMON.INTERACT'
2969       include 'COMMON.CONTACTS'
2970       include 'COMMON.TORSION'
2971       include 'COMMON.VECTORS'
2972       include 'COMMON.FFIELD'
2973       include 'COMMON.TIME1'
2974       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2975      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2976       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2977      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2978      &    gmuij2(4),gmuji2(4)
2979       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2980      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2981      &    num_conti,j1,j2
2982 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2983 #ifdef MOMENT
2984       double precision scal_el /1.0d0/
2985 #else
2986       double precision scal_el /0.5d0/
2987 #endif
2988 C 12/13/98
2989 C 13-go grudnia roku pamietnego...
2990       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2991      &                   0.0d0,1.0d0,0.0d0,
2992      &                   0.0d0,0.0d0,1.0d0/
2993 c          time00=MPI_Wtime()
2994 cd      write (iout,*) "eelecij",i,j
2995 c          ind=ind+1
2996           iteli=itel(i)
2997           itelj=itel(j)
2998           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2999           aaa=app(iteli,itelj)
3000           bbb=bpp(iteli,itelj)
3001           ael6i=ael6(iteli,itelj)
3002           ael3i=ael3(iteli,itelj)
3003           dxj=dc(1,j)
3004           dyj=dc(2,j)
3005           dzj=dc(3,j)
3006           dx_normj=dc_norm(1,j)
3007           dy_normj=dc_norm(2,j)
3008           dz_normj=dc_norm(3,j)
3009           xj=c(1,j)+0.5D0*dxj-xmedi
3010           yj=c(2,j)+0.5D0*dyj-ymedi
3011           zj=c(3,j)+0.5D0*dzj-zmedi
3012           rij=xj*xj+yj*yj+zj*zj
3013           rrmij=1.0D0/rij
3014           rij=dsqrt(rij)
3015           rmij=1.0D0/rij
3016           r3ij=rrmij*rmij
3017           r6ij=r3ij*r3ij
3018           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3019           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3020           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3021           fac=cosa-3.0D0*cosb*cosg
3022           ev1=aaa*r6ij*r6ij
3023 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3024           if (j.eq.i+2) ev1=scal_el*ev1
3025           ev2=bbb*r6ij
3026           fac3=ael6i*r6ij
3027           fac4=ael3i*r3ij
3028           evdwij=ev1+ev2
3029           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3030           el2=fac4*fac
3031           eesij=el1+el2
3032 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3033           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3034           ees=ees+eesij
3035           evdw1=evdw1+evdwij
3036 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3037 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3038 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3039 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3040
3041           if (energy_dec) then
3042               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3043      &'evdw1',i,j,evdwij
3044      &,iteli,itelj,aaa,evdw1
3045               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3046           endif
3047
3048 C
3049 C Calculate contributions to the Cartesian gradient.
3050 C
3051 #ifdef SPLITELE
3052           facvdw=-6*rrmij*(ev1+evdwij)
3053           facel=-3*rrmij*(el1+eesij)
3054           fac1=fac
3055           erij(1)=xj*rmij
3056           erij(2)=yj*rmij
3057           erij(3)=zj*rmij
3058 *
3059 * Radial derivatives. First process both termini of the fragment (i,j)
3060 *
3061           ggg(1)=facel*xj
3062           ggg(2)=facel*yj
3063           ggg(3)=facel*zj
3064 c          do k=1,3
3065 c            ghalf=0.5D0*ggg(k)
3066 c            gelc(k,i)=gelc(k,i)+ghalf
3067 c            gelc(k,j)=gelc(k,j)+ghalf
3068 c          enddo
3069 c 9/28/08 AL Gradient compotents will be summed only at the end
3070           do k=1,3
3071             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3072             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3073           enddo
3074 *
3075 * Loop over residues i+1 thru j-1.
3076 *
3077 cgrad          do k=i+1,j-1
3078 cgrad            do l=1,3
3079 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3080 cgrad            enddo
3081 cgrad          enddo
3082           ggg(1)=facvdw*xj
3083           ggg(2)=facvdw*yj
3084           ggg(3)=facvdw*zj
3085 c          do k=1,3
3086 c            ghalf=0.5D0*ggg(k)
3087 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3088 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3089 c          enddo
3090 c 9/28/08 AL Gradient compotents will be summed only at the end
3091           do k=1,3
3092             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3093             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3094           enddo
3095 *
3096 * Loop over residues i+1 thru j-1.
3097 *
3098 cgrad          do k=i+1,j-1
3099 cgrad            do l=1,3
3100 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3101 cgrad            enddo
3102 cgrad          enddo
3103 #else
3104           facvdw=ev1+evdwij
3105           facel=el1+eesij
3106           fac1=fac
3107           fac=-3*rrmij*(facvdw+facvdw+facel)
3108           erij(1)=xj*rmij
3109           erij(2)=yj*rmij
3110           erij(3)=zj*rmij
3111 *
3112 * Radial derivatives. First process both termini of the fragment (i,j)
3113 *
3114           ggg(1)=fac*xj
3115           ggg(2)=fac*yj
3116           ggg(3)=fac*zj
3117 c          do k=1,3
3118 c            ghalf=0.5D0*ggg(k)
3119 c            gelc(k,i)=gelc(k,i)+ghalf
3120 c            gelc(k,j)=gelc(k,j)+ghalf
3121 c          enddo
3122 c 9/28/08 AL Gradient compotents will be summed only at the end
3123           do k=1,3
3124             gelc_long(k,j)=gelc(k,j)+ggg(k)
3125             gelc_long(k,i)=gelc(k,i)-ggg(k)
3126           enddo
3127 *
3128 * Loop over residues i+1 thru j-1.
3129 *
3130 cgrad          do k=i+1,j-1
3131 cgrad            do l=1,3
3132 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3133 cgrad            enddo
3134 cgrad          enddo
3135 c 9/28/08 AL Gradient compotents will be summed only at the end
3136           ggg(1)=facvdw*xj
3137           ggg(2)=facvdw*yj
3138           ggg(3)=facvdw*zj
3139           do k=1,3
3140             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3141             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3142           enddo
3143 #endif
3144 *
3145 * Angular part
3146 *
3147           ecosa=2.0D0*fac3*fac1+fac4
3148           fac4=-3.0D0*fac4
3149           fac3=-6.0D0*fac3
3150           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3151           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3152           do k=1,3
3153             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3154             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3155           enddo
3156 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3157 cd   &          (dcosg(k),k=1,3)
3158           do k=1,3
3159             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3160           enddo
3161 c          do k=1,3
3162 c            ghalf=0.5D0*ggg(k)
3163 c            gelc(k,i)=gelc(k,i)+ghalf
3164 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3165 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3166 c            gelc(k,j)=gelc(k,j)+ghalf
3167 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3168 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3169 c          enddo
3170 cgrad          do k=i+1,j-1
3171 cgrad            do l=1,3
3172 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3173 cgrad            enddo
3174 cgrad          enddo
3175           do k=1,3
3176             gelc(k,i)=gelc(k,i)
3177      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3178      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3179             gelc(k,j)=gelc(k,j)
3180      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3181      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3182             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3183             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3184           enddo
3185           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3186      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3187      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3188 C
3189 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3190 C   energy of a peptide unit is assumed in the form of a second-order
3191 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3192 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3193 C   are computed for EVERY pair of non-contiguous peptide groups.
3194 C
3195
3196           if (j.lt.nres-1) then
3197             j1=j+1
3198             j2=j-1
3199           else
3200             j1=j-1
3201             j2=j-2
3202           endif
3203           kkk=0
3204           lll=0
3205           do k=1,2
3206             do l=1,2
3207               kkk=kkk+1
3208               muij(kkk)=mu(k,i)*mu(l,j)
3209 #ifdef NEWCORR
3210              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3211 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(k,i),k,i
3212              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3213              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3214 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(l,j),l,j
3215              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3216 #endif
3217             enddo
3218           enddo
3219 cd         write (iout,*) 'EELEC: i',i,' j',j
3220 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3221 cd          write(iout,*) 'muij',muij
3222           ury=scalar(uy(1,i),erij)
3223           urz=scalar(uz(1,i),erij)
3224           vry=scalar(uy(1,j),erij)
3225           vrz=scalar(uz(1,j),erij)
3226           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3227           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3228           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3229           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3230           fac=dsqrt(-ael6i)*r3ij
3231           a22=a22*fac
3232           a23=a23*fac
3233           a32=a32*fac
3234           a33=a33*fac
3235 cd          write (iout,'(4i5,4f10.5)')
3236 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3237 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3238 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3239 cd     &      uy(:,j),uz(:,j)
3240 cd          write (iout,'(4f10.5)')
3241 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3242 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3243 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3244 cd           write (iout,'(9f10.5/)')
3245 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3246 C Derivatives of the elements of A in virtual-bond vectors
3247           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3248           do k=1,3
3249             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3250             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3251             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3252             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3253             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3254             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3255             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3256             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3257             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3258             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3259             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3260             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3261           enddo
3262 C Compute radial contributions to the gradient
3263           facr=-3.0d0*rrmij
3264           a22der=a22*facr
3265           a23der=a23*facr
3266           a32der=a32*facr
3267           a33der=a33*facr
3268           agg(1,1)=a22der*xj
3269           agg(2,1)=a22der*yj
3270           agg(3,1)=a22der*zj
3271           agg(1,2)=a23der*xj
3272           agg(2,2)=a23der*yj
3273           agg(3,2)=a23der*zj
3274           agg(1,3)=a32der*xj
3275           agg(2,3)=a32der*yj
3276           agg(3,3)=a32der*zj
3277           agg(1,4)=a33der*xj
3278           agg(2,4)=a33der*yj
3279           agg(3,4)=a33der*zj
3280 C Add the contributions coming from er
3281           fac3=-3.0d0*fac
3282           do k=1,3
3283             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3284             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3285             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3286             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3287           enddo
3288           do k=1,3
3289 C Derivatives in DC(i)
3290 cgrad            ghalf1=0.5d0*agg(k,1)
3291 cgrad            ghalf2=0.5d0*agg(k,2)
3292 cgrad            ghalf3=0.5d0*agg(k,3)
3293 cgrad            ghalf4=0.5d0*agg(k,4)
3294             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3295      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3296             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3297      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3298             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3299      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3300             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3301      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3302 C Derivatives in DC(i+1)
3303             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3304      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3305             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3306      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3307             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3308      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3309             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3310      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3311 C Derivatives in DC(j)
3312             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3313      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3314             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3315      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3316             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3317      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3318             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3319      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3320 C Derivatives in DC(j+1) or DC(nres-1)
3321             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3322      &      -3.0d0*vryg(k,3)*ury)
3323             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3324      &      -3.0d0*vrzg(k,3)*ury)
3325             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3326      &      -3.0d0*vryg(k,3)*urz)
3327             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3328      &      -3.0d0*vrzg(k,3)*urz)
3329 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3330 cgrad              do l=1,4
3331 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3332 cgrad              enddo
3333 cgrad            endif
3334           enddo
3335           acipa(1,1)=a22
3336           acipa(1,2)=a23
3337           acipa(2,1)=a32
3338           acipa(2,2)=a33
3339           a22=-a22
3340           a23=-a23
3341           do l=1,2
3342             do k=1,3
3343               agg(k,l)=-agg(k,l)
3344               aggi(k,l)=-aggi(k,l)
3345               aggi1(k,l)=-aggi1(k,l)
3346               aggj(k,l)=-aggj(k,l)
3347               aggj1(k,l)=-aggj1(k,l)
3348             enddo
3349           enddo
3350           if (j.lt.nres-1) then
3351             a22=-a22
3352             a32=-a32
3353             do l=1,3,2
3354               do k=1,3
3355                 agg(k,l)=-agg(k,l)
3356                 aggi(k,l)=-aggi(k,l)
3357                 aggi1(k,l)=-aggi1(k,l)
3358                 aggj(k,l)=-aggj(k,l)
3359                 aggj1(k,l)=-aggj1(k,l)
3360               enddo
3361             enddo
3362           else
3363             a22=-a22
3364             a23=-a23
3365             a32=-a32
3366             a33=-a33
3367             do l=1,4
3368               do k=1,3
3369                 agg(k,l)=-agg(k,l)
3370                 aggi(k,l)=-aggi(k,l)
3371                 aggi1(k,l)=-aggi1(k,l)
3372                 aggj(k,l)=-aggj(k,l)
3373                 aggj1(k,l)=-aggj1(k,l)
3374               enddo
3375             enddo
3376           endif
3377           ENDIF ! WCORR
3378           IF (wel_loc.gt.0.0d0) THEN
3379 c           if ((i.eq.8).and.(j.eq.14)) then
3380 C Contribution to the local-electrostatic energy coming from the i-j pair
3381           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3382      &     +a33*muij(4)
3383 C Calculate patrial derivative for theta angle
3384 #ifdef NEWCORR
3385          geel_loc_ij=a22*gmuij1(1)
3386      &     +a23*gmuij1(2)
3387      &     +a32*gmuij1(3)
3388      &     +a33*gmuij1(4)
3389 c         write(iout,*) "derivative over thatai"
3390 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3391 c     &   a33*gmuij1(4)
3392          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3393      &      geel_loc_ij*wel_loc
3394 c         write(iout,*) "derivative over thatai-1"
3395 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3396 c     &   a33*gmuij2(4)
3397          geel_loc_ij=a22*gmuij2(1)+a23*gmuij2(2)+a32*gmuij2(3)
3398      &     +a33*gmuij2(4)
3399          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3400      &      geel_loc_ij*wel_loc
3401          geel_loc_ji=a22*gmuji1(1)+a23*gmuji1(2)+a32*gmuji1(3)
3402      &     +a33*gmuji1(4)
3403 c         write(iout,*) "derivative over thataj"
3404 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3405 c     &   a33*gmuji1(4)
3406
3407          gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3408      &      geel_loc_ji*wel_loc
3409          geel_loc_ji=a22*gmuji2(1)+a23*gmuji2(2)+a32*gmuji2(3)
3410      &     +a33*gmuji2(4)
3411 c         write(iout,*) "derivative over thataj-1"
3412 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3413 c     &   a33*gmuji2(4)
3414          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3415      &      geel_loc_ji*wel_loc
3416 #endif
3417 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3418
3419           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3420      &            'eelloc',i,j,eel_loc_ij
3421 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3422
3423           eel_loc=eel_loc+eel_loc_ij
3424 C Partial derivatives in virtual-bond dihedral angles gamma
3425           if (i.gt.1)
3426      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3427      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3428      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3429           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3430      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3431      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3432 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3433           do l=1,3
3434             ggg(l)=agg(l,1)*muij(1)+
3435      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3436             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3437             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3438 cgrad            ghalf=0.5d0*ggg(l)
3439 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3440 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3441           enddo
3442 cgrad          do k=i+1,j2
3443 cgrad            do l=1,3
3444 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3445 cgrad            enddo
3446 cgrad          enddo
3447 C Remaining derivatives of eello
3448           do l=1,3
3449             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3450      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3451             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3452      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3453             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3454      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3455             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3456      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3457           enddo
3458 c          endif
3459           ENDIF
3460 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3461 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3462           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3463      &       .and. num_conti.le.maxconts) then
3464 c            write (iout,*) i,j," entered corr"
3465 C
3466 C Calculate the contact function. The ith column of the array JCONT will
3467 C contain the numbers of atoms that make contacts with the atom I (of numbers
3468 C greater than I). The arrays FACONT and GACONT will contain the values of
3469 C the contact function and its derivative.
3470 c           r0ij=1.02D0*rpp(iteli,itelj)
3471 c           r0ij=1.11D0*rpp(iteli,itelj)
3472             r0ij=2.20D0*rpp(iteli,itelj)
3473 c           r0ij=1.55D0*rpp(iteli,itelj)
3474             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3475             if (fcont.gt.0.0D0) then
3476               num_conti=num_conti+1
3477               if (num_conti.gt.maxconts) then
3478                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3479      &                         ' will skip next contacts for this conf.'
3480               else
3481                 jcont_hb(num_conti,i)=j
3482 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3483 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3484                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3485      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3486 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3487 C  terms.
3488                 d_cont(num_conti,i)=rij
3489 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3490 C     --- Electrostatic-interaction matrix ---
3491                 a_chuj(1,1,num_conti,i)=a22
3492                 a_chuj(1,2,num_conti,i)=a23
3493                 a_chuj(2,1,num_conti,i)=a32
3494                 a_chuj(2,2,num_conti,i)=a33
3495 C     --- Gradient of rij
3496                 do kkk=1,3
3497                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3498                 enddo
3499                 kkll=0
3500                 do k=1,2
3501                   do l=1,2
3502                     kkll=kkll+1
3503                     do m=1,3
3504                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3505                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3506                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3507                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3508                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3509                     enddo
3510                   enddo
3511                 enddo
3512                 ENDIF
3513                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3514 C Calculate contact energies
3515                 cosa4=4.0D0*cosa
3516                 wij=cosa-3.0D0*cosb*cosg
3517                 cosbg1=cosb+cosg
3518                 cosbg2=cosb-cosg
3519 c               fac3=dsqrt(-ael6i)/r0ij**3
3520                 fac3=dsqrt(-ael6i)*r3ij
3521 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3522                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3523                 if (ees0tmp.gt.0) then
3524                   ees0pij=dsqrt(ees0tmp)
3525                 else
3526                   ees0pij=0
3527                 endif
3528 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3529                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3530                 if (ees0tmp.gt.0) then
3531                   ees0mij=dsqrt(ees0tmp)
3532                 else
3533                   ees0mij=0
3534                 endif
3535 c               ees0mij=0.0D0
3536                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3537                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3538 C Diagnostics. Comment out or remove after debugging!
3539 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3540 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3541 c               ees0m(num_conti,i)=0.0D0
3542 C End diagnostics.
3543 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3544 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3545 C Angular derivatives of the contact function
3546                 ees0pij1=fac3/ees0pij
3547                 ees0mij1=fac3/ees0mij
3548                 fac3p=-3.0D0*fac3*rrmij
3549                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3550                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3551 c               ees0mij1=0.0D0
3552                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3553                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3554                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3555                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3556                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3557                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3558                 ecosap=ecosa1+ecosa2
3559                 ecosbp=ecosb1+ecosb2
3560                 ecosgp=ecosg1+ecosg2
3561                 ecosam=ecosa1-ecosa2
3562                 ecosbm=ecosb1-ecosb2
3563                 ecosgm=ecosg1-ecosg2
3564 C Diagnostics
3565 c               ecosap=ecosa1
3566 c               ecosbp=ecosb1
3567 c               ecosgp=ecosg1
3568 c               ecosam=0.0D0
3569 c               ecosbm=0.0D0
3570 c               ecosgm=0.0D0
3571 C End diagnostics
3572                 facont_hb(num_conti,i)=fcont
3573                 fprimcont=fprimcont/rij
3574 cd              facont_hb(num_conti,i)=1.0D0
3575 C Following line is for diagnostics.
3576 cd              fprimcont=0.0D0
3577                 do k=1,3
3578                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3579                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3580                 enddo
3581                 do k=1,3
3582                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3583                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3584                 enddo
3585                 gggp(1)=gggp(1)+ees0pijp*xj
3586                 gggp(2)=gggp(2)+ees0pijp*yj
3587                 gggp(3)=gggp(3)+ees0pijp*zj
3588                 gggm(1)=gggm(1)+ees0mijp*xj
3589                 gggm(2)=gggm(2)+ees0mijp*yj
3590                 gggm(3)=gggm(3)+ees0mijp*zj
3591 C Derivatives due to the contact function
3592                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3593                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3594                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3595                 do k=1,3
3596 c
3597 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3598 c          following the change of gradient-summation algorithm.
3599 c
3600 cgrad                  ghalfp=0.5D0*gggp(k)
3601 cgrad                  ghalfm=0.5D0*gggm(k)
3602                   gacontp_hb1(k,num_conti,i)=!ghalfp
3603      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3604      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3605                   gacontp_hb2(k,num_conti,i)=!ghalfp
3606      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3607      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3608                   gacontp_hb3(k,num_conti,i)=gggp(k)
3609                   gacontm_hb1(k,num_conti,i)=!ghalfm
3610      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3611      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3612                   gacontm_hb2(k,num_conti,i)=!ghalfm
3613      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3614      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3615                   gacontm_hb3(k,num_conti,i)=gggm(k)
3616                 enddo
3617 C Diagnostics. Comment out or remove after debugging!
3618 cdiag           do k=1,3
3619 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3620 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3621 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3622 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3623 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3624 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3625 cdiag           enddo
3626               ENDIF ! wcorr
3627               endif  ! num_conti.le.maxconts
3628             endif  ! fcont.gt.0
3629           endif    ! j.gt.i+1
3630           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3631             do k=1,4
3632               do l=1,3
3633                 ghalf=0.5d0*agg(l,k)
3634                 aggi(l,k)=aggi(l,k)+ghalf
3635                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3636                 aggj(l,k)=aggj(l,k)+ghalf
3637               enddo
3638             enddo
3639             if (j.eq.nres-1 .and. i.lt.j-2) then
3640               do k=1,4
3641                 do l=1,3
3642                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3643                 enddo
3644               enddo
3645             endif
3646           endif
3647 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3648       return
3649       end
3650 C-----------------------------------------------------------------------------
3651       subroutine eturn3(i,eello_turn3)
3652 C Third- and fourth-order contributions from turns
3653       implicit real*8 (a-h,o-z)
3654       include 'DIMENSIONS'
3655       include 'COMMON.IOUNITS'
3656       include 'COMMON.GEO'
3657       include 'COMMON.VAR'
3658       include 'COMMON.LOCAL'
3659       include 'COMMON.CHAIN'
3660       include 'COMMON.DERIV'
3661       include 'COMMON.INTERACT'
3662       include 'COMMON.CONTACTS'
3663       include 'COMMON.TORSION'
3664       include 'COMMON.VECTORS'
3665       include 'COMMON.FFIELD'
3666       include 'COMMON.CONTROL'
3667       dimension ggg(3)
3668       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3669      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3670      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3671      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3672      &  auxgmat2(2,2),auxgmatt2(2,2)
3673       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3674      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3675       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3676      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3677      &    num_conti,j1,j2
3678       j=i+2
3679 c      write (iout,*) "eturn3",i,j,j1,j2
3680       a_temp(1,1)=a22
3681       a_temp(1,2)=a23
3682       a_temp(2,1)=a32
3683       a_temp(2,2)=a33
3684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3685 C
3686 C               Third-order contributions
3687 C
3688 C                 (i+2)o----(i+3)
3689 C                      | |
3690 C                      | |
3691 C                 (i+1)o----i
3692 C
3693 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3694 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3695         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3696 c auxalary matices for theta gradient
3697 c auxalary matrix for i+1 and constant i+2
3698         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3699 c auxalary matrix for i+2 and constant i+1
3700         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3701         call transpose2(auxmat(1,1),auxmat1(1,1))
3702         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3703         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3704         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3705         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3706         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3707         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3708 C Derivatives in theta
3709         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3710      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3711         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3712      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3713
3714         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3715      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3716 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3717 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3718 cd     &    ' eello_turn3_num',4*eello_turn3_num
3719 C Derivatives in gamma(i)
3720         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3721         call transpose2(auxmat2(1,1),auxmat3(1,1))
3722         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3723         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3724 C Derivatives in gamma(i+1)
3725         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3726         call transpose2(auxmat2(1,1),auxmat3(1,1))
3727         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3728         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3729      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3730 C Cartesian derivatives
3731         do l=1,3
3732 c            ghalf1=0.5d0*agg(l,1)
3733 c            ghalf2=0.5d0*agg(l,2)
3734 c            ghalf3=0.5d0*agg(l,3)
3735 c            ghalf4=0.5d0*agg(l,4)
3736           a_temp(1,1)=aggi(l,1)!+ghalf1
3737           a_temp(1,2)=aggi(l,2)!+ghalf2
3738           a_temp(2,1)=aggi(l,3)!+ghalf3
3739           a_temp(2,2)=aggi(l,4)!+ghalf4
3740           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3741           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3742      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3743           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3744           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3745           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3746           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3747           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3748           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3749      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3750           a_temp(1,1)=aggj(l,1)!+ghalf1
3751           a_temp(1,2)=aggj(l,2)!+ghalf2
3752           a_temp(2,1)=aggj(l,3)!+ghalf3
3753           a_temp(2,2)=aggj(l,4)!+ghalf4
3754           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3755           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3756      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3757           a_temp(1,1)=aggj1(l,1)
3758           a_temp(1,2)=aggj1(l,2)
3759           a_temp(2,1)=aggj1(l,3)
3760           a_temp(2,2)=aggj1(l,4)
3761           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3762           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3763      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3764         enddo
3765       return
3766       end
3767 C-------------------------------------------------------------------------------
3768       subroutine eturn4(i,eello_turn4)
3769 C Third- and fourth-order contributions from turns
3770       implicit real*8 (a-h,o-z)
3771       include 'DIMENSIONS'
3772       include 'COMMON.IOUNITS'
3773       include 'COMMON.GEO'
3774       include 'COMMON.VAR'
3775       include 'COMMON.LOCAL'
3776       include 'COMMON.CHAIN'
3777       include 'COMMON.DERIV'
3778       include 'COMMON.INTERACT'
3779       include 'COMMON.CONTACTS'
3780       include 'COMMON.TORSION'
3781       include 'COMMON.VECTORS'
3782       include 'COMMON.FFIELD'
3783       include 'COMMON.CONTROL'
3784       dimension ggg(3)
3785       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3786      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3787      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3788      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3789      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3790      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3791      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3792       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3793      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3794       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3795      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3796      &    num_conti,j1,j2
3797       j=i+3
3798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3799 C
3800 C               Fourth-order contributions
3801 C
3802 C                 (i+3)o----(i+4)
3803 C                     /  |
3804 C               (i+2)o   |
3805 C                     \  |
3806 C                 (i+1)o----i
3807 C
3808 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3809 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3810 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3811 c        write(iout,*)"WCHODZE W PROGRAM"
3812         a_temp(1,1)=a22
3813         a_temp(1,2)=a23
3814         a_temp(2,1)=a32
3815         a_temp(2,2)=a33
3816         iti1=itortyp(itype(i+1))
3817         iti2=itortyp(itype(i+2))
3818         iti3=itortyp(itype(i+3))
3819 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3820         call transpose2(EUg(1,1,i+1),e1t(1,1))
3821         call transpose2(Eug(1,1,i+2),e2t(1,1))
3822         call transpose2(Eug(1,1,i+3),e3t(1,1))
3823 C Ematrix derivative in theta
3824         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3825         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3826         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3827         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3828 c       eta1 in derivative theta
3829         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3830         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3831 c       auxgvec is derivative of Ub2 so i+3 theta
3832         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3833 c       auxalary matrix of E i+1
3834         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3835 c        s1=0.0
3836 c        gs1=0.0
3837         s1=scalar2(b1(1,i+2),auxvec(1))
3838 c derivative of theta i+2 with constant i+3
3839         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3840 c derivative of theta i+2 with constant i+2
3841         gs32=scalar2(b1(1,i+2),auxgvec(1))
3842 c derivative of E matix in theta of i+1
3843         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3844
3845         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3846 c       ea31 in derivative theta
3847         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3848         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3849 c auxilary matrix auxgvec of Ub2 with constant E matirx
3850         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3851 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3852         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3853
3854 c        s2=0.0
3855 c        gs2=0.0
3856         s2=scalar2(b1(1,i+1),auxvec(1))
3857 c derivative of theta i+1 with constant i+3
3858         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3859 c derivative of theta i+2 with constant i+1
3860         gs21=scalar2(b1(1,i+1),auxgvec(1))
3861 c derivative of theta i+3 with constant i+1
3862         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3863 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3864 c     &  gtb1(1,i+1)
3865         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3866 c two derivatives over diffetent matrices
3867 c gtae3e2 is derivative over i+3
3868         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3869 c ae3gte2 is derivative over i+2
3870         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3871         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3872 c three possible derivative over theta E matices
3873 c i+1
3874         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3875 c i+2
3876         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3877 c i+3
3878         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3879         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3880
3881         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3882         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3883         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3884
3885         eello_turn4=eello_turn4-(s1+s2+s3)
3886 #ifdef NEWCORR
3887         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3888      &                  -(gs13+gsE13+gsEE1)*wturn4
3889         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3890      &                    -(gs23+gs21+gsEE2)*wturn4
3891         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3892      &                    -(gs32+gsE31+gsEE3)*wturn4
3893 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3894 c     &   gs2
3895 #endif
3896         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3897      &      'eturn4',i,j,-(s1+s2+s3)
3898 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3899 c     &    ' eello_turn4_num',8*eello_turn4_num
3900 C Derivatives in gamma(i)
3901         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3902         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3903         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3904         s1=scalar2(b1(1,i+2),auxvec(1))
3905         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3906         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3907         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3908 C Derivatives in gamma(i+1)
3909         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3910         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3911         s2=scalar2(b1(1,i+1),auxvec(1))
3912         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3913         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3914         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3915         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3916 C Derivatives in gamma(i+2)
3917         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3918         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3919         s1=scalar2(b1(1,i+2),auxvec(1))
3920         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3921         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3922         s2=scalar2(b1(1,i+1),auxvec(1))
3923         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3924         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3925         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3927 C Cartesian derivatives
3928 C Derivatives of this turn contributions in DC(i+2)
3929         if (j.lt.nres-1) then
3930           do l=1,3
3931             a_temp(1,1)=agg(l,1)
3932             a_temp(1,2)=agg(l,2)
3933             a_temp(2,1)=agg(l,3)
3934             a_temp(2,2)=agg(l,4)
3935             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3936             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3937             s1=scalar2(b1(1,i+2),auxvec(1))
3938             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3939             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3940             s2=scalar2(b1(1,i+1),auxvec(1))
3941             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3942             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3943             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3944             ggg(l)=-(s1+s2+s3)
3945             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3946           enddo
3947         endif
3948 C Remaining derivatives of this turn contribution
3949         do l=1,3
3950           a_temp(1,1)=aggi(l,1)
3951           a_temp(1,2)=aggi(l,2)
3952           a_temp(2,1)=aggi(l,3)
3953           a_temp(2,2)=aggi(l,4)
3954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3956           s1=scalar2(b1(1,i+2),auxvec(1))
3957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3959           s2=scalar2(b1(1,i+1),auxvec(1))
3960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3963           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3964           a_temp(1,1)=aggi1(l,1)
3965           a_temp(1,2)=aggi1(l,2)
3966           a_temp(2,1)=aggi1(l,3)
3967           a_temp(2,2)=aggi1(l,4)
3968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3970           s1=scalar2(b1(1,i+2),auxvec(1))
3971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3973           s2=scalar2(b1(1,i+1),auxvec(1))
3974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3977           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3978           a_temp(1,1)=aggj(l,1)
3979           a_temp(1,2)=aggj(l,2)
3980           a_temp(2,1)=aggj(l,3)
3981           a_temp(2,2)=aggj(l,4)
3982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3984           s1=scalar2(b1(1,i+2),auxvec(1))
3985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3987           s2=scalar2(b1(1,i+1),auxvec(1))
3988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3991           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3992           a_temp(1,1)=aggj1(l,1)
3993           a_temp(1,2)=aggj1(l,2)
3994           a_temp(2,1)=aggj1(l,3)
3995           a_temp(2,2)=aggj1(l,4)
3996           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3997           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3998           s1=scalar2(b1(1,i+2),auxvec(1))
3999           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4000           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4001           s2=scalar2(b1(1,i+1),auxvec(1))
4002           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4003           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4004           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4005 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4006           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4007         enddo
4008       return
4009       end
4010 C-----------------------------------------------------------------------------
4011       subroutine vecpr(u,v,w)
4012       implicit real*8(a-h,o-z)
4013       dimension u(3),v(3),w(3)
4014       w(1)=u(2)*v(3)-u(3)*v(2)
4015       w(2)=-u(1)*v(3)+u(3)*v(1)
4016       w(3)=u(1)*v(2)-u(2)*v(1)
4017       return
4018       end
4019 C-----------------------------------------------------------------------------
4020       subroutine unormderiv(u,ugrad,unorm,ungrad)
4021 C This subroutine computes the derivatives of a normalized vector u, given
4022 C the derivatives computed without normalization conditions, ugrad. Returns
4023 C ungrad.
4024       implicit none
4025       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4026       double precision vec(3)
4027       double precision scalar
4028       integer i,j
4029 c      write (2,*) 'ugrad',ugrad
4030 c      write (2,*) 'u',u
4031       do i=1,3
4032         vec(i)=scalar(ugrad(1,i),u(1))
4033       enddo
4034 c      write (2,*) 'vec',vec
4035       do i=1,3
4036         do j=1,3
4037           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4038         enddo
4039       enddo
4040 c      write (2,*) 'ungrad',ungrad
4041       return
4042       end
4043 C-----------------------------------------------------------------------------
4044       subroutine escp_soft_sphere(evdw2,evdw2_14)
4045 C
4046 C This subroutine calculates the excluded-volume interaction energy between
4047 C peptide-group centers and side chains and its gradient in virtual-bond and
4048 C side-chain vectors.
4049 C
4050       implicit real*8 (a-h,o-z)
4051       include 'DIMENSIONS'
4052       include 'COMMON.GEO'
4053       include 'COMMON.VAR'
4054       include 'COMMON.LOCAL'
4055       include 'COMMON.CHAIN'
4056       include 'COMMON.DERIV'
4057       include 'COMMON.INTERACT'
4058       include 'COMMON.FFIELD'
4059       include 'COMMON.IOUNITS'
4060       include 'COMMON.CONTROL'
4061       dimension ggg(3)
4062       evdw2=0.0D0
4063       evdw2_14=0.0d0
4064       r0_scp=4.5d0
4065 cd    print '(a)','Enter ESCP'
4066 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4067       do i=iatscp_s,iatscp_e
4068         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4069         iteli=itel(i)
4070         xi=0.5D0*(c(1,i)+c(1,i+1))
4071         yi=0.5D0*(c(2,i)+c(2,i+1))
4072         zi=0.5D0*(c(3,i)+c(3,i+1))
4073
4074         do iint=1,nscp_gr(i)
4075
4076         do j=iscpstart(i,iint),iscpend(i,iint)
4077           if (itype(j).eq.ntyp1) cycle
4078           itypj=iabs(itype(j))
4079 C Uncomment following three lines for SC-p interactions
4080 c         xj=c(1,nres+j)-xi
4081 c         yj=c(2,nres+j)-yi
4082 c         zj=c(3,nres+j)-zi
4083 C Uncomment following three lines for Ca-p interactions
4084           xj=c(1,j)-xi
4085           yj=c(2,j)-yi
4086           zj=c(3,j)-zi
4087           rij=xj*xj+yj*yj+zj*zj
4088           r0ij=r0_scp
4089           r0ijsq=r0ij*r0ij
4090           if (rij.lt.r0ijsq) then
4091             evdwij=0.25d0*(rij-r0ijsq)**2
4092             fac=rij-r0ijsq
4093           else
4094             evdwij=0.0d0
4095             fac=0.0d0
4096           endif
4097           evdw2=evdw2+evdwij
4098 C
4099 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4100 C
4101           ggg(1)=xj*fac
4102           ggg(2)=yj*fac
4103           ggg(3)=zj*fac
4104 cgrad          if (j.lt.i) then
4105 cd          write (iout,*) 'j<i'
4106 C Uncomment following three lines for SC-p interactions
4107 c           do k=1,3
4108 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4109 c           enddo
4110 cgrad          else
4111 cd          write (iout,*) 'j>i'
4112 cgrad            do k=1,3
4113 cgrad              ggg(k)=-ggg(k)
4114 C Uncomment following line for SC-p interactions
4115 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4116 cgrad            enddo
4117 cgrad          endif
4118 cgrad          do k=1,3
4119 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4120 cgrad          enddo
4121 cgrad          kstart=min0(i+1,j)
4122 cgrad          kend=max0(i-1,j-1)
4123 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4124 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4125 cgrad          do k=kstart,kend
4126 cgrad            do l=1,3
4127 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4128 cgrad            enddo
4129 cgrad          enddo
4130           do k=1,3
4131             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4132             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4133           enddo
4134         enddo
4135
4136         enddo ! iint
4137       enddo ! i
4138       return
4139       end
4140 C-----------------------------------------------------------------------------
4141       subroutine escp(evdw2,evdw2_14)
4142 C
4143 C This subroutine calculates the excluded-volume interaction energy between
4144 C peptide-group centers and side chains and its gradient in virtual-bond and
4145 C side-chain vectors.
4146 C
4147       implicit real*8 (a-h,o-z)
4148       include 'DIMENSIONS'
4149       include 'COMMON.GEO'
4150       include 'COMMON.VAR'
4151       include 'COMMON.LOCAL'
4152       include 'COMMON.CHAIN'
4153       include 'COMMON.DERIV'
4154       include 'COMMON.INTERACT'
4155       include 'COMMON.FFIELD'
4156       include 'COMMON.IOUNITS'
4157       include 'COMMON.CONTROL'
4158       dimension ggg(3)
4159       evdw2=0.0D0
4160       evdw2_14=0.0d0
4161 cd    print '(a)','Enter ESCP'
4162 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4163       do i=iatscp_s,iatscp_e
4164         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4165         iteli=itel(i)
4166         xi=0.5D0*(c(1,i)+c(1,i+1))
4167         yi=0.5D0*(c(2,i)+c(2,i+1))
4168         zi=0.5D0*(c(3,i)+c(3,i+1))
4169
4170         do iint=1,nscp_gr(i)
4171
4172         do j=iscpstart(i,iint),iscpend(i,iint)
4173           itypj=iabs(itype(j))
4174           if (itypj.eq.ntyp1) cycle
4175 C Uncomment following three lines for SC-p interactions
4176 c         xj=c(1,nres+j)-xi
4177 c         yj=c(2,nres+j)-yi
4178 c         zj=c(3,nres+j)-zi
4179 C Uncomment following three lines for Ca-p interactions
4180           xj=c(1,j)-xi
4181           yj=c(2,j)-yi
4182           zj=c(3,j)-zi
4183           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4184           fac=rrij**expon2
4185           e1=fac*fac*aad(itypj,iteli)
4186           e2=fac*bad(itypj,iteli)
4187           if (iabs(j-i) .le. 2) then
4188             e1=scal14*e1
4189             e2=scal14*e2
4190             evdw2_14=evdw2_14+e1+e2
4191           endif
4192           evdwij=e1+e2
4193           evdw2=evdw2+evdwij
4194           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4195      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4196      &       bad(itypj,iteli)
4197 C
4198 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4199 C
4200           fac=-(evdwij+e1)*rrij
4201           ggg(1)=xj*fac
4202           ggg(2)=yj*fac
4203           ggg(3)=zj*fac
4204 cgrad          if (j.lt.i) then
4205 cd          write (iout,*) 'j<i'
4206 C Uncomment following three lines for SC-p interactions
4207 c           do k=1,3
4208 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4209 c           enddo
4210 cgrad          else
4211 cd          write (iout,*) 'j>i'
4212 cgrad            do k=1,3
4213 cgrad              ggg(k)=-ggg(k)
4214 C Uncomment following line for SC-p interactions
4215 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4216 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4217 cgrad            enddo
4218 cgrad          endif
4219 cgrad          do k=1,3
4220 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4221 cgrad          enddo
4222 cgrad          kstart=min0(i+1,j)
4223 cgrad          kend=max0(i-1,j-1)
4224 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4225 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4226 cgrad          do k=kstart,kend
4227 cgrad            do l=1,3
4228 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4229 cgrad            enddo
4230 cgrad          enddo
4231           do k=1,3
4232             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4233             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4234           enddo
4235         enddo
4236
4237         enddo ! iint
4238       enddo ! i
4239       do i=1,nct
4240         do j=1,3
4241           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4242           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4243           gradx_scp(j,i)=expon*gradx_scp(j,i)
4244         enddo
4245       enddo
4246 C******************************************************************************
4247 C
4248 C                              N O T E !!!
4249 C
4250 C To save time the factor EXPON has been extracted from ALL components
4251 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4252 C use!
4253 C
4254 C******************************************************************************
4255       return
4256       end
4257 C--------------------------------------------------------------------------
4258       subroutine edis(ehpb)
4259 C
4260 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4261 C
4262       implicit real*8 (a-h,o-z)
4263       include 'DIMENSIONS'
4264       include 'COMMON.SBRIDGE'
4265       include 'COMMON.CHAIN'
4266       include 'COMMON.DERIV'
4267       include 'COMMON.VAR'
4268       include 'COMMON.INTERACT'
4269       include 'COMMON.IOUNITS'
4270       dimension ggg(3)
4271       ehpb=0.0D0
4272 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4273 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4274       if (link_end.eq.0) return
4275       do i=link_start,link_end
4276 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4277 C CA-CA distance used in regularization of structure.
4278         ii=ihpb(i)
4279         jj=jhpb(i)
4280 C iii and jjj point to the residues for which the distance is assigned.
4281         if (ii.gt.nres) then
4282           iii=ii-nres
4283           jjj=jj-nres
4284         else
4285           iii=ii
4286           jjj=jj
4287         endif
4288 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4289 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4290 C    distance and angle dependent SS bond potential.
4291         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4292      & iabs(itype(jjj)).eq.1) then
4293           call ssbond_ene(iii,jjj,eij)
4294           ehpb=ehpb+2*eij
4295 cd          write (iout,*) "eij",eij
4296         else
4297 C Calculate the distance between the two points and its difference from the
4298 C target distance.
4299         dd=dist(ii,jj)
4300         rdis=dd-dhpb(i)
4301 C Get the force constant corresponding to this distance.
4302         waga=forcon(i)
4303 C Calculate the contribution to energy.
4304         ehpb=ehpb+waga*rdis*rdis
4305 C
4306 C Evaluate gradient.
4307 C
4308         fac=waga*rdis/dd
4309 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4310 cd   &   ' waga=',waga,' fac=',fac
4311         do j=1,3
4312           ggg(j)=fac*(c(j,jj)-c(j,ii))
4313         enddo
4314 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4315 C If this is a SC-SC distance, we need to calculate the contributions to the
4316 C Cartesian gradient in the SC vectors (ghpbx).
4317         if (iii.lt.ii) then
4318           do j=1,3
4319             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4320             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4321           enddo
4322         endif
4323 cgrad        do j=iii,jjj-1
4324 cgrad          do k=1,3
4325 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4326 cgrad          enddo
4327 cgrad        enddo
4328         do k=1,3
4329           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4330           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4331         enddo
4332         endif
4333       enddo
4334       ehpb=0.5D0*ehpb
4335       return
4336       end
4337 C--------------------------------------------------------------------------
4338       subroutine ssbond_ene(i,j,eij)
4339 C
4340 C Calculate the distance and angle dependent SS-bond potential energy
4341 C using a free-energy function derived based on RHF/6-31G** ab initio
4342 C calculations of diethyl disulfide.
4343 C
4344 C A. Liwo and U. Kozlowska, 11/24/03
4345 C
4346       implicit real*8 (a-h,o-z)
4347       include 'DIMENSIONS'
4348       include 'COMMON.SBRIDGE'
4349       include 'COMMON.CHAIN'
4350       include 'COMMON.DERIV'
4351       include 'COMMON.LOCAL'
4352       include 'COMMON.INTERACT'
4353       include 'COMMON.VAR'
4354       include 'COMMON.IOUNITS'
4355       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4356       itypi=iabs(itype(i))
4357       xi=c(1,nres+i)
4358       yi=c(2,nres+i)
4359       zi=c(3,nres+i)
4360       dxi=dc_norm(1,nres+i)
4361       dyi=dc_norm(2,nres+i)
4362       dzi=dc_norm(3,nres+i)
4363 c      dsci_inv=dsc_inv(itypi)
4364       dsci_inv=vbld_inv(nres+i)
4365       itypj=iabs(itype(j))
4366 c      dscj_inv=dsc_inv(itypj)
4367       dscj_inv=vbld_inv(nres+j)
4368       xj=c(1,nres+j)-xi
4369       yj=c(2,nres+j)-yi
4370       zj=c(3,nres+j)-zi
4371       dxj=dc_norm(1,nres+j)
4372       dyj=dc_norm(2,nres+j)
4373       dzj=dc_norm(3,nres+j)
4374       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4375       rij=dsqrt(rrij)
4376       erij(1)=xj*rij
4377       erij(2)=yj*rij
4378       erij(3)=zj*rij
4379       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4380       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4381       om12=dxi*dxj+dyi*dyj+dzi*dzj
4382       do k=1,3
4383         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4384         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4385       enddo
4386       rij=1.0d0/rij
4387       deltad=rij-d0cm
4388       deltat1=1.0d0-om1
4389       deltat2=1.0d0+om2
4390       deltat12=om2-om1+2.0d0
4391       cosphi=om12-om1*om2
4392       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4393      &  +akct*deltad*deltat12
4394      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4395 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4396 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4397 c     &  " deltat12",deltat12," eij",eij
4398       ed=2*akcm*deltad+akct*deltat12
4399       pom1=akct*deltad
4400       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4401       eom1=-2*akth*deltat1-pom1-om2*pom2
4402       eom2= 2*akth*deltat2+pom1-om1*pom2
4403       eom12=pom2
4404       do k=1,3
4405         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4406         ghpbx(k,i)=ghpbx(k,i)-ggk
4407      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4408      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4409         ghpbx(k,j)=ghpbx(k,j)+ggk
4410      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4411      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4412         ghpbc(k,i)=ghpbc(k,i)-ggk
4413         ghpbc(k,j)=ghpbc(k,j)+ggk
4414       enddo
4415 C
4416 C Calculate the components of the gradient in DC and X
4417 C
4418 cgrad      do k=i,j-1
4419 cgrad        do l=1,3
4420 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4421 cgrad        enddo
4422 cgrad      enddo
4423       return
4424       end
4425 C--------------------------------------------------------------------------
4426       subroutine ebond(estr)
4427 c
4428 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4429 c
4430       implicit real*8 (a-h,o-z)
4431       include 'DIMENSIONS'
4432       include 'COMMON.LOCAL'
4433       include 'COMMON.GEO'
4434       include 'COMMON.INTERACT'
4435       include 'COMMON.DERIV'
4436       include 'COMMON.VAR'
4437       include 'COMMON.CHAIN'
4438       include 'COMMON.IOUNITS'
4439       include 'COMMON.NAMES'
4440       include 'COMMON.FFIELD'
4441       include 'COMMON.CONTROL'
4442       include 'COMMON.SETUP'
4443       double precision u(3),ud(3)
4444       estr=0.0d0
4445       estr1=0.0d0
4446       do i=ibondp_start,ibondp_end
4447         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4448           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4449           do j=1,3
4450           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4451      &      *dc(j,i-1)/vbld(i)
4452           enddo
4453           if (energy_dec) write(iout,*)
4454      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4455         else
4456         diff = vbld(i)-vbldp0
4457         if (energy_dec) write (iout,*)
4458      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4459         estr=estr+diff*diff
4460         do j=1,3
4461           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4462         enddo
4463 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4464         endif
4465       enddo
4466       estr=0.5d0*AKP*estr+estr1
4467 c
4468 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4469 c
4470       do i=ibond_start,ibond_end
4471         iti=iabs(itype(i))
4472         if (iti.ne.10 .and. iti.ne.ntyp1) then
4473           nbi=nbondterm(iti)
4474           if (nbi.eq.1) then
4475             diff=vbld(i+nres)-vbldsc0(1,iti)
4476             if (energy_dec) write (iout,*)
4477      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4478      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4479             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4480             do j=1,3
4481               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4482             enddo
4483           else
4484             do j=1,nbi
4485               diff=vbld(i+nres)-vbldsc0(j,iti)
4486               ud(j)=aksc(j,iti)*diff
4487               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4488             enddo
4489             uprod=u(1)
4490             do j=2,nbi
4491               uprod=uprod*u(j)
4492             enddo
4493             usum=0.0d0
4494             usumsqder=0.0d0
4495             do j=1,nbi
4496               uprod1=1.0d0
4497               uprod2=1.0d0
4498               do k=1,nbi
4499                 if (k.ne.j) then
4500                   uprod1=uprod1*u(k)
4501                   uprod2=uprod2*u(k)*u(k)
4502                 endif
4503               enddo
4504               usum=usum+uprod1
4505               usumsqder=usumsqder+ud(j)*uprod2
4506             enddo
4507             estr=estr+uprod/usum
4508             do j=1,3
4509              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4510             enddo
4511           endif
4512         endif
4513       enddo
4514       return
4515       end
4516 #ifdef CRYST_THETA
4517 C--------------------------------------------------------------------------
4518       subroutine ebend(etheta)
4519 C
4520 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4521 C angles gamma and its derivatives in consecutive thetas and gammas.
4522 C
4523       implicit real*8 (a-h,o-z)
4524       include 'DIMENSIONS'
4525       include 'COMMON.LOCAL'
4526       include 'COMMON.GEO'
4527       include 'COMMON.INTERACT'
4528       include 'COMMON.DERIV'
4529       include 'COMMON.VAR'
4530       include 'COMMON.CHAIN'
4531       include 'COMMON.IOUNITS'
4532       include 'COMMON.NAMES'
4533       include 'COMMON.FFIELD'
4534       include 'COMMON.CONTROL'
4535       common /calcthet/ term1,term2,termm,diffak,ratak,
4536      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4537      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4538       double precision y(2),z(2)
4539       delta=0.02d0*pi
4540 c      time11=dexp(-2*time)
4541 c      time12=1.0d0
4542       etheta=0.0D0
4543 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4544       do i=ithet_start,ithet_end
4545         if (itype(i-1).eq.ntyp1) cycle
4546 C Zero the energy function and its derivative at 0 or pi.
4547         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4548         it=itype(i-1)
4549         ichir1=isign(1,itype(i-2))
4550         ichir2=isign(1,itype(i))
4551          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4552          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4553          if (itype(i-1).eq.10) then
4554           itype1=isign(10,itype(i-2))
4555           ichir11=isign(1,itype(i-2))
4556           ichir12=isign(1,itype(i-2))
4557           itype2=isign(10,itype(i))
4558           ichir21=isign(1,itype(i))
4559           ichir22=isign(1,itype(i))
4560          endif
4561
4562         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4563 #ifdef OSF
4564           phii=phi(i)
4565           if (phii.ne.phii) phii=150.0
4566 #else
4567           phii=phi(i)
4568 #endif
4569           y(1)=dcos(phii)
4570           y(2)=dsin(phii)
4571         else
4572           y(1)=0.0D0
4573           y(2)=0.0D0
4574         endif
4575         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4576 #ifdef OSF
4577           phii1=phi(i+1)
4578           if (phii1.ne.phii1) phii1=150.0
4579           phii1=pinorm(phii1)
4580           z(1)=cos(phii1)
4581 #else
4582           phii1=phi(i+1)
4583           z(1)=dcos(phii1)
4584 #endif
4585           z(2)=dsin(phii1)
4586         else
4587           z(1)=0.0D0
4588           z(2)=0.0D0
4589         endif
4590 C Calculate the "mean" value of theta from the part of the distribution
4591 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4592 C In following comments this theta will be referred to as t_c.
4593         thet_pred_mean=0.0d0
4594         do k=1,2
4595             athetk=athet(k,it,ichir1,ichir2)
4596             bthetk=bthet(k,it,ichir1,ichir2)
4597           if (it.eq.10) then
4598              athetk=athet(k,itype1,ichir11,ichir12)
4599              bthetk=bthet(k,itype2,ichir21,ichir22)
4600           endif
4601          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4602         enddo
4603         dthett=thet_pred_mean*ssd
4604         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4605 C Derivatives of the "mean" values in gamma1 and gamma2.
4606         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4607      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4608          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4609      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4610          if (it.eq.10) then
4611       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4612      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4613         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4614      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4615          endif
4616         if (theta(i).gt.pi-delta) then
4617           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4618      &         E_tc0)
4619           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4620           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4621           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4622      &        E_theta)
4623           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4624      &        E_tc)
4625         else if (theta(i).lt.delta) then
4626           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4627           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4628           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4629      &        E_theta)
4630           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4631           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4632      &        E_tc)
4633         else
4634           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4635      &        E_theta,E_tc)
4636         endif
4637         etheta=etheta+ethetai
4638         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4639      &      'ebend',i,ethetai
4640         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4641         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4642         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4643       enddo
4644 C Ufff.... We've done all this!!!
4645       return
4646       end
4647 C---------------------------------------------------------------------------
4648       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4649      &     E_tc)
4650       implicit real*8 (a-h,o-z)
4651       include 'DIMENSIONS'
4652       include 'COMMON.LOCAL'
4653       include 'COMMON.IOUNITS'
4654       common /calcthet/ term1,term2,termm,diffak,ratak,
4655      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4656      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4657 C Calculate the contributions to both Gaussian lobes.
4658 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4659 C The "polynomial part" of the "standard deviation" of this part of
4660 C the distribution.
4661         sig=polthet(3,it)
4662         do j=2,0,-1
4663           sig=sig*thet_pred_mean+polthet(j,it)
4664         enddo
4665 C Derivative of the "interior part" of the "standard deviation of the"
4666 C gamma-dependent Gaussian lobe in t_c.
4667         sigtc=3*polthet(3,it)
4668         do j=2,1,-1
4669           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4670         enddo
4671         sigtc=sig*sigtc
4672 C Set the parameters of both Gaussian lobes of the distribution.
4673 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4674         fac=sig*sig+sigc0(it)
4675         sigcsq=fac+fac
4676         sigc=1.0D0/sigcsq
4677 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4678         sigsqtc=-4.0D0*sigcsq*sigtc
4679 c       print *,i,sig,sigtc,sigsqtc
4680 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4681         sigtc=-sigtc/(fac*fac)
4682 C Following variable is sigma(t_c)**(-2)
4683         sigcsq=sigcsq*sigcsq
4684         sig0i=sig0(it)
4685         sig0inv=1.0D0/sig0i**2
4686         delthec=thetai-thet_pred_mean
4687         delthe0=thetai-theta0i
4688         term1=-0.5D0*sigcsq*delthec*delthec
4689         term2=-0.5D0*sig0inv*delthe0*delthe0
4690 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4691 C NaNs in taking the logarithm. We extract the largest exponent which is added
4692 C to the energy (this being the log of the distribution) at the end of energy
4693 C term evaluation for this virtual-bond angle.
4694         if (term1.gt.term2) then
4695           termm=term1
4696           term2=dexp(term2-termm)
4697           term1=1.0d0
4698         else
4699           termm=term2
4700           term1=dexp(term1-termm)
4701           term2=1.0d0
4702         endif
4703 C The ratio between the gamma-independent and gamma-dependent lobes of
4704 C the distribution is a Gaussian function of thet_pred_mean too.
4705         diffak=gthet(2,it)-thet_pred_mean
4706         ratak=diffak/gthet(3,it)**2
4707         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4708 C Let's differentiate it in thet_pred_mean NOW.
4709         aktc=ak*ratak
4710 C Now put together the distribution terms to make complete distribution.
4711         termexp=term1+ak*term2
4712         termpre=sigc+ak*sig0i
4713 C Contribution of the bending energy from this theta is just the -log of
4714 C the sum of the contributions from the two lobes and the pre-exponential
4715 C factor. Simple enough, isn't it?
4716         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4717 C NOW the derivatives!!!
4718 C 6/6/97 Take into account the deformation.
4719         E_theta=(delthec*sigcsq*term1
4720      &       +ak*delthe0*sig0inv*term2)/termexp
4721         E_tc=((sigtc+aktc*sig0i)/termpre
4722      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4723      &       aktc*term2)/termexp)
4724       return
4725       end
4726 c-----------------------------------------------------------------------------
4727       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4728       implicit real*8 (a-h,o-z)
4729       include 'DIMENSIONS'
4730       include 'COMMON.LOCAL'
4731       include 'COMMON.IOUNITS'
4732       common /calcthet/ term1,term2,termm,diffak,ratak,
4733      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4734      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4735       delthec=thetai-thet_pred_mean
4736       delthe0=thetai-theta0i
4737 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4738       t3 = thetai-thet_pred_mean
4739       t6 = t3**2
4740       t9 = term1
4741       t12 = t3*sigcsq
4742       t14 = t12+t6*sigsqtc
4743       t16 = 1.0d0
4744       t21 = thetai-theta0i
4745       t23 = t21**2
4746       t26 = term2
4747       t27 = t21*t26
4748       t32 = termexp
4749       t40 = t32**2
4750       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4751      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4752      & *(-t12*t9-ak*sig0inv*t27)
4753       return
4754       end
4755 #else
4756 C--------------------------------------------------------------------------
4757       subroutine ebend(etheta)
4758 C
4759 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4760 C angles gamma and its derivatives in consecutive thetas and gammas.
4761 C ab initio-derived potentials from
4762 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4763 C
4764       implicit real*8 (a-h,o-z)
4765       include 'DIMENSIONS'
4766       include 'COMMON.LOCAL'
4767       include 'COMMON.GEO'
4768       include 'COMMON.INTERACT'
4769       include 'COMMON.DERIV'
4770       include 'COMMON.VAR'
4771       include 'COMMON.CHAIN'
4772       include 'COMMON.IOUNITS'
4773       include 'COMMON.NAMES'
4774       include 'COMMON.FFIELD'
4775       include 'COMMON.CONTROL'
4776       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4777      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4778      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4779      & sinph1ph2(maxdouble,maxdouble)
4780       logical lprn /.false./, lprn1 /.false./
4781       etheta=0.0D0
4782       do i=ithet_start,ithet_end
4783         if (itype(i-1).eq.ntyp1) cycle
4784         if (iabs(itype(i+1)).eq.20) iblock=2
4785         if (iabs(itype(i+1)).ne.20) iblock=1
4786         dethetai=0.0d0
4787         dephii=0.0d0
4788         dephii1=0.0d0
4789         theti2=0.5d0*theta(i)
4790         ityp2=ithetyp((itype(i-1)))
4791         do k=1,nntheterm
4792           coskt(k)=dcos(k*theti2)
4793           sinkt(k)=dsin(k*theti2)
4794         enddo
4795         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4796 #ifdef OSF
4797           phii=phi(i)
4798           if (phii.ne.phii) phii=150.0
4799 #else
4800           phii=phi(i)
4801 #endif
4802           ityp1=ithetyp((itype(i-2)))
4803 C propagation of chirality for glycine type
4804           do k=1,nsingle
4805             cosph1(k)=dcos(k*phii)
4806             sinph1(k)=dsin(k*phii)
4807           enddo
4808         else
4809           phii=0.0d0
4810           ityp1=nthetyp+1
4811           do k=1,nsingle
4812             cosph1(k)=0.0d0
4813             sinph1(k)=0.0d0
4814           enddo
4815         endif
4816         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4817 #ifdef OSF
4818           phii1=phi(i+1)
4819           if (phii1.ne.phii1) phii1=150.0
4820           phii1=pinorm(phii1)
4821 #else
4822           phii1=phi(i+1)
4823 #endif
4824           ityp3=ithetyp((itype(i)))
4825           do k=1,nsingle
4826             cosph2(k)=dcos(k*phii1)
4827             sinph2(k)=dsin(k*phii1)
4828           enddo
4829         else
4830           phii1=0.0d0
4831           ityp3=nthetyp+1
4832           do k=1,nsingle
4833             cosph2(k)=0.0d0
4834             sinph2(k)=0.0d0
4835           enddo
4836         endif
4837         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4838         do k=1,ndouble
4839           do l=1,k-1
4840             ccl=cosph1(l)*cosph2(k-l)
4841             ssl=sinph1(l)*sinph2(k-l)
4842             scl=sinph1(l)*cosph2(k-l)
4843             csl=cosph1(l)*sinph2(k-l)
4844             cosph1ph2(l,k)=ccl-ssl
4845             cosph1ph2(k,l)=ccl+ssl
4846             sinph1ph2(l,k)=scl+csl
4847             sinph1ph2(k,l)=scl-csl
4848           enddo
4849         enddo
4850         if (lprn) then
4851         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4852      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4853         write (iout,*) "coskt and sinkt"
4854         do k=1,nntheterm
4855           write (iout,*) k,coskt(k),sinkt(k)
4856         enddo
4857         endif
4858         do k=1,ntheterm
4859           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4860           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4861      &      *coskt(k)
4862           if (lprn)
4863      &    write (iout,*) "k",k,"
4864      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4865      &     " ethetai",ethetai
4866         enddo
4867         if (lprn) then
4868         write (iout,*) "cosph and sinph"
4869         do k=1,nsingle
4870           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4871         enddo
4872         write (iout,*) "cosph1ph2 and sinph2ph2"
4873         do k=2,ndouble
4874           do l=1,k-1
4875             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4876      &         sinph1ph2(l,k),sinph1ph2(k,l)
4877           enddo
4878         enddo
4879         write(iout,*) "ethetai",ethetai
4880         endif
4881         do m=1,ntheterm2
4882           do k=1,nsingle
4883             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4884      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4885      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4886      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4887             ethetai=ethetai+sinkt(m)*aux
4888             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4889             dephii=dephii+k*sinkt(m)*(
4890      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4891      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4892             dephii1=dephii1+k*sinkt(m)*(
4893      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4894      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4895             if (lprn)
4896      &      write (iout,*) "m",m," k",k," bbthet",
4897      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4898      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4899      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4900      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4901           enddo
4902         enddo
4903         if (lprn)
4904      &  write(iout,*) "ethetai",ethetai
4905         do m=1,ntheterm3
4906           do k=2,ndouble
4907             do l=1,k-1
4908               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4909      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4910      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4911      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4912               ethetai=ethetai+sinkt(m)*aux
4913               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4914               dephii=dephii+l*sinkt(m)*(
4915      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4916      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4917      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4918      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4919               dephii1=dephii1+(k-l)*sinkt(m)*(
4920      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4921      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4922      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4923      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4924               if (lprn) then
4925               write (iout,*) "m",m," k",k," l",l," ffthet",
4926      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4927      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4928      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4929      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4930      &            " ethetai",ethetai
4931               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4932      &            cosph1ph2(k,l)*sinkt(m),
4933      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4934               endif
4935             enddo
4936           enddo
4937         enddo
4938 10      continue
4939 c        lprn1=.true.
4940         if (lprn1)
4941      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4942      &   i,theta(i)*rad2deg,phii*rad2deg,
4943      &   phii1*rad2deg,ethetai
4944 c        lprn1=.false.
4945         etheta=etheta+ethetai
4946         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4947         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4948         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4949       enddo
4950       return
4951       end
4952 #endif
4953 #ifdef CRYST_SC
4954 c-----------------------------------------------------------------------------
4955       subroutine esc(escloc)
4956 C Calculate the local energy of a side chain and its derivatives in the
4957 C corresponding virtual-bond valence angles THETA and the spherical angles
4958 C ALPHA and OMEGA.
4959       implicit real*8 (a-h,o-z)
4960       include 'DIMENSIONS'
4961       include 'COMMON.GEO'
4962       include 'COMMON.LOCAL'
4963       include 'COMMON.VAR'
4964       include 'COMMON.INTERACT'
4965       include 'COMMON.DERIV'
4966       include 'COMMON.CHAIN'
4967       include 'COMMON.IOUNITS'
4968       include 'COMMON.NAMES'
4969       include 'COMMON.FFIELD'
4970       include 'COMMON.CONTROL'
4971       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4972      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4973       common /sccalc/ time11,time12,time112,theti,it,nlobit
4974       delta=0.02d0*pi
4975       escloc=0.0D0
4976 c     write (iout,'(a)') 'ESC'
4977       do i=loc_start,loc_end
4978         it=itype(i)
4979         if (it.eq.ntyp1) cycle
4980         if (it.eq.10) goto 1
4981         nlobit=nlob(iabs(it))
4982 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4983 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4984         theti=theta(i+1)-pipol
4985         x(1)=dtan(theti)
4986         x(2)=alph(i)
4987         x(3)=omeg(i)
4988
4989         if (x(2).gt.pi-delta) then
4990           xtemp(1)=x(1)
4991           xtemp(2)=pi-delta
4992           xtemp(3)=x(3)
4993           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4994           xtemp(2)=pi
4995           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4996           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4997      &        escloci,dersc(2))
4998           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4999      &        ddersc0(1),dersc(1))
5000           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5001      &        ddersc0(3),dersc(3))
5002           xtemp(2)=pi-delta
5003           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5004           xtemp(2)=pi
5005           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5006           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5007      &            dersc0(2),esclocbi,dersc02)
5008           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5009      &            dersc12,dersc01)
5010           call splinthet(x(2),0.5d0*delta,ss,ssd)
5011           dersc0(1)=dersc01
5012           dersc0(2)=dersc02
5013           dersc0(3)=0.0d0
5014           do k=1,3
5015             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5016           enddo
5017           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5018 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5019 c    &             esclocbi,ss,ssd
5020           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5021 c         escloci=esclocbi
5022 c         write (iout,*) escloci
5023         else if (x(2).lt.delta) then
5024           xtemp(1)=x(1)
5025           xtemp(2)=delta
5026           xtemp(3)=x(3)
5027           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5028           xtemp(2)=0.0d0
5029           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5030           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5031      &        escloci,dersc(2))
5032           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5033      &        ddersc0(1),dersc(1))
5034           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5035      &        ddersc0(3),dersc(3))
5036           xtemp(2)=delta
5037           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5038           xtemp(2)=0.0d0
5039           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5040           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5041      &            dersc0(2),esclocbi,dersc02)
5042           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5043      &            dersc12,dersc01)
5044           dersc0(1)=dersc01
5045           dersc0(2)=dersc02
5046           dersc0(3)=0.0d0
5047           call splinthet(x(2),0.5d0*delta,ss,ssd)
5048           do k=1,3
5049             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5050           enddo
5051           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5052 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5053 c    &             esclocbi,ss,ssd
5054           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5055 c         write (iout,*) escloci
5056         else
5057           call enesc(x,escloci,dersc,ddummy,.false.)
5058         endif
5059
5060         escloc=escloc+escloci
5061         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5062      &     'escloc',i,escloci
5063 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5064
5065         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5066      &   wscloc*dersc(1)
5067         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5068         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5069     1   continue
5070       enddo
5071       return
5072       end
5073 C---------------------------------------------------------------------------
5074       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5075       implicit real*8 (a-h,o-z)
5076       include 'DIMENSIONS'
5077       include 'COMMON.GEO'
5078       include 'COMMON.LOCAL'
5079       include 'COMMON.IOUNITS'
5080       common /sccalc/ time11,time12,time112,theti,it,nlobit
5081       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5082       double precision contr(maxlob,-1:1)
5083       logical mixed
5084 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5085         escloc_i=0.0D0
5086         do j=1,3
5087           dersc(j)=0.0D0
5088           if (mixed) ddersc(j)=0.0d0
5089         enddo
5090         x3=x(3)
5091
5092 C Because of periodicity of the dependence of the SC energy in omega we have
5093 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5094 C To avoid underflows, first compute & store the exponents.
5095
5096         do iii=-1,1
5097
5098           x(3)=x3+iii*dwapi
5099
5100           do j=1,nlobit
5101             do k=1,3
5102               z(k)=x(k)-censc(k,j,it)
5103             enddo
5104             do k=1,3
5105               Axk=0.0D0
5106               do l=1,3
5107                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5108               enddo
5109               Ax(k,j,iii)=Axk
5110             enddo
5111             expfac=0.0D0
5112             do k=1,3
5113               expfac=expfac+Ax(k,j,iii)*z(k)
5114             enddo
5115             contr(j,iii)=expfac
5116           enddo ! j
5117
5118         enddo ! iii
5119
5120         x(3)=x3
5121 C As in the case of ebend, we want to avoid underflows in exponentiation and
5122 C subsequent NaNs and INFs in energy calculation.
5123 C Find the largest exponent
5124         emin=contr(1,-1)
5125         do iii=-1,1
5126           do j=1,nlobit
5127             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5128           enddo
5129         enddo
5130         emin=0.5D0*emin
5131 cd      print *,'it=',it,' emin=',emin
5132
5133 C Compute the contribution to SC energy and derivatives
5134         do iii=-1,1
5135
5136           do j=1,nlobit
5137 #ifdef OSF
5138             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5139             if(adexp.ne.adexp) adexp=1.0
5140             expfac=dexp(adexp)
5141 #else
5142             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5143 #endif
5144 cd          print *,'j=',j,' expfac=',expfac
5145             escloc_i=escloc_i+expfac
5146             do k=1,3
5147               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5148             enddo
5149             if (mixed) then
5150               do k=1,3,2
5151                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5152      &            +gaussc(k,2,j,it))*expfac
5153               enddo
5154             endif
5155           enddo
5156
5157         enddo ! iii
5158
5159         dersc(1)=dersc(1)/cos(theti)**2
5160         ddersc(1)=ddersc(1)/cos(theti)**2
5161         ddersc(3)=ddersc(3)
5162
5163         escloci=-(dlog(escloc_i)-emin)
5164         do j=1,3
5165           dersc(j)=dersc(j)/escloc_i
5166         enddo
5167         if (mixed) then
5168           do j=1,3,2
5169             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5170           enddo
5171         endif
5172       return
5173       end
5174 C------------------------------------------------------------------------------
5175       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5176       implicit real*8 (a-h,o-z)
5177       include 'DIMENSIONS'
5178       include 'COMMON.GEO'
5179       include 'COMMON.LOCAL'
5180       include 'COMMON.IOUNITS'
5181       common /sccalc/ time11,time12,time112,theti,it,nlobit
5182       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5183       double precision contr(maxlob)
5184       logical mixed
5185
5186       escloc_i=0.0D0
5187
5188       do j=1,3
5189         dersc(j)=0.0D0
5190       enddo
5191
5192       do j=1,nlobit
5193         do k=1,2
5194           z(k)=x(k)-censc(k,j,it)
5195         enddo
5196         z(3)=dwapi
5197         do k=1,3
5198           Axk=0.0D0
5199           do l=1,3
5200             Axk=Axk+gaussc(l,k,j,it)*z(l)
5201           enddo
5202           Ax(k,j)=Axk
5203         enddo
5204         expfac=0.0D0
5205         do k=1,3
5206           expfac=expfac+Ax(k,j)*z(k)
5207         enddo
5208         contr(j)=expfac
5209       enddo ! j
5210
5211 C As in the case of ebend, we want to avoid underflows in exponentiation and
5212 C subsequent NaNs and INFs in energy calculation.
5213 C Find the largest exponent
5214       emin=contr(1)
5215       do j=1,nlobit
5216         if (emin.gt.contr(j)) emin=contr(j)
5217       enddo
5218       emin=0.5D0*emin
5219
5220 C Compute the contribution to SC energy and derivatives
5221
5222       dersc12=0.0d0
5223       do j=1,nlobit
5224         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5225         escloc_i=escloc_i+expfac
5226         do k=1,2
5227           dersc(k)=dersc(k)+Ax(k,j)*expfac
5228         enddo
5229         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5230      &            +gaussc(1,2,j,it))*expfac
5231         dersc(3)=0.0d0
5232       enddo
5233
5234       dersc(1)=dersc(1)/cos(theti)**2
5235       dersc12=dersc12/cos(theti)**2
5236       escloci=-(dlog(escloc_i)-emin)
5237       do j=1,2
5238         dersc(j)=dersc(j)/escloc_i
5239       enddo
5240       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5241       return
5242       end
5243 #else
5244 c----------------------------------------------------------------------------------
5245       subroutine esc(escloc)
5246 C Calculate the local energy of a side chain and its derivatives in the
5247 C corresponding virtual-bond valence angles THETA and the spherical angles
5248 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5249 C added by Urszula Kozlowska. 07/11/2007
5250 C
5251       implicit real*8 (a-h,o-z)
5252       include 'DIMENSIONS'
5253       include 'COMMON.GEO'
5254       include 'COMMON.LOCAL'
5255       include 'COMMON.VAR'
5256       include 'COMMON.SCROT'
5257       include 'COMMON.INTERACT'
5258       include 'COMMON.DERIV'
5259       include 'COMMON.CHAIN'
5260       include 'COMMON.IOUNITS'
5261       include 'COMMON.NAMES'
5262       include 'COMMON.FFIELD'
5263       include 'COMMON.CONTROL'
5264       include 'COMMON.VECTORS'
5265       double precision x_prime(3),y_prime(3),z_prime(3)
5266      &    , sumene,dsc_i,dp2_i,x(65),
5267      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5268      &    de_dxx,de_dyy,de_dzz,de_dt
5269       double precision s1_t,s1_6_t,s2_t,s2_6_t
5270       double precision
5271      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5272      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5273      & dt_dCi(3),dt_dCi1(3)
5274       common /sccalc/ time11,time12,time112,theti,it,nlobit
5275       delta=0.02d0*pi
5276       escloc=0.0D0
5277       do i=loc_start,loc_end
5278         if (itype(i).eq.ntyp1) cycle
5279         costtab(i+1) =dcos(theta(i+1))
5280         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5281         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5282         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5283         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5284         cosfac=dsqrt(cosfac2)
5285         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5286         sinfac=dsqrt(sinfac2)
5287         it=iabs(itype(i))
5288         if (it.eq.10) goto 1
5289 c
5290 C  Compute the axes of tghe local cartesian coordinates system; store in
5291 c   x_prime, y_prime and z_prime
5292 c
5293         do j=1,3
5294           x_prime(j) = 0.00
5295           y_prime(j) = 0.00
5296           z_prime(j) = 0.00
5297         enddo
5298 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5299 C     &   dc_norm(3,i+nres)
5300         do j = 1,3
5301           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5302           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5303         enddo
5304         do j = 1,3
5305           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5306         enddo
5307 c       write (2,*) "i",i
5308 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5309 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5310 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5311 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5312 c      & " xy",scalar(x_prime(1),y_prime(1)),
5313 c      & " xz",scalar(x_prime(1),z_prime(1)),
5314 c      & " yy",scalar(y_prime(1),y_prime(1)),
5315 c      & " yz",scalar(y_prime(1),z_prime(1)),
5316 c      & " zz",scalar(z_prime(1),z_prime(1))
5317 c
5318 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5319 C to local coordinate system. Store in xx, yy, zz.
5320 c
5321         xx=0.0d0
5322         yy=0.0d0
5323         zz=0.0d0
5324         do j = 1,3
5325           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5326           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5327           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5328         enddo
5329
5330         xxtab(i)=xx
5331         yytab(i)=yy
5332         zztab(i)=zz
5333 C
5334 C Compute the energy of the ith side cbain
5335 C
5336 c        write (2,*) "xx",xx," yy",yy," zz",zz
5337         it=iabs(itype(i))
5338         do j = 1,65
5339           x(j) = sc_parmin(j,it)
5340         enddo
5341 #ifdef CHECK_COORD
5342 Cc diagnostics - remove later
5343         xx1 = dcos(alph(2))
5344         yy1 = dsin(alph(2))*dcos(omeg(2))
5345         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5346         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5347      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5348      &    xx1,yy1,zz1
5349 C,"  --- ", xx_w,yy_w,zz_w
5350 c end diagnostics
5351 #endif
5352         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5353      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5354      &   + x(10)*yy*zz
5355         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5356      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5357      & + x(20)*yy*zz
5358         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5359      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5360      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5361      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5362      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5363      &  +x(40)*xx*yy*zz
5364         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5365      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5366      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5367      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5368      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5369      &  +x(60)*xx*yy*zz
5370         dsc_i   = 0.743d0+x(61)
5371         dp2_i   = 1.9d0+x(62)
5372         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5373      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5374         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5375      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5376         s1=(1+x(63))/(0.1d0 + dscp1)
5377         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5378         s2=(1+x(65))/(0.1d0 + dscp2)
5379         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5380         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5381      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5382 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5383 c     &   sumene4,
5384 c     &   dscp1,dscp2,sumene
5385 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         escloc = escloc + sumene
5387 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5388 c     & ,zz,xx,yy
5389 c#define DEBUG
5390 #ifdef DEBUG
5391 C
5392 C This section to check the numerical derivatives of the energy of ith side
5393 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5394 C #define DEBUG in the code to turn it on.
5395 C
5396         write (2,*) "sumene               =",sumene
5397         aincr=1.0d-7
5398         xxsave=xx
5399         xx=xx+aincr
5400         write (2,*) xx,yy,zz
5401         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5402         de_dxx_num=(sumenep-sumene)/aincr
5403         xx=xxsave
5404         write (2,*) "xx+ sumene from enesc=",sumenep
5405         yysave=yy
5406         yy=yy+aincr
5407         write (2,*) xx,yy,zz
5408         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5409         de_dyy_num=(sumenep-sumene)/aincr
5410         yy=yysave
5411         write (2,*) "yy+ sumene from enesc=",sumenep
5412         zzsave=zz
5413         zz=zz+aincr
5414         write (2,*) xx,yy,zz
5415         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5416         de_dzz_num=(sumenep-sumene)/aincr
5417         zz=zzsave
5418         write (2,*) "zz+ sumene from enesc=",sumenep
5419         costsave=cost2tab(i+1)
5420         sintsave=sint2tab(i+1)
5421         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5422         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5423         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5424         de_dt_num=(sumenep-sumene)/aincr
5425         write (2,*) " t+ sumene from enesc=",sumenep
5426         cost2tab(i+1)=costsave
5427         sint2tab(i+1)=sintsave
5428 C End of diagnostics section.
5429 #endif
5430 C
5431 C Compute the gradient of esc
5432 C
5433 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5434         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5435         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5436         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5437         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5438         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5439         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5440         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5441         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5442         pom1=(sumene3*sint2tab(i+1)+sumene1)
5443      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5444         pom2=(sumene4*cost2tab(i+1)+sumene2)
5445      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5446         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5447         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5448      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5449      &  +x(40)*yy*zz
5450         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5451         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5452      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5453      &  +x(60)*yy*zz
5454         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5455      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5456      &        +(pom1+pom2)*pom_dx
5457 #ifdef DEBUG
5458         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5459 #endif
5460 C
5461         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5462         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5463      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5464      &  +x(40)*xx*zz
5465         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5466         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5467      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5468      &  +x(59)*zz**2 +x(60)*xx*zz
5469         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5470      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5471      &        +(pom1-pom2)*pom_dy
5472 #ifdef DEBUG
5473         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5474 #endif
5475 C
5476         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5477      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5478      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5479      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5480      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5481      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5482      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5483      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5484 #ifdef DEBUG
5485         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5486 #endif
5487 C
5488         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5489      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5490      &  +pom1*pom_dt1+pom2*pom_dt2
5491 #ifdef DEBUG
5492         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5493 #endif
5494 c#undef DEBUG
5495 c
5496 C
5497        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5498        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5499        cosfac2xx=cosfac2*xx
5500        sinfac2yy=sinfac2*yy
5501        do k = 1,3
5502          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5503      &      vbld_inv(i+1)
5504          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5505      &      vbld_inv(i)
5506          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5507          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5508 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5509 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5510 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5511 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5512          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5513          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5514          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5515          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5516          dZZ_Ci1(k)=0.0d0
5517          dZZ_Ci(k)=0.0d0
5518          do j=1,3
5519            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5520      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5521            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5522      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5523          enddo
5524
5525          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5526          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5527          dZZ_XYZ(k)=vbld_inv(i+nres)*
5528      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5529 c
5530          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5531          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5532        enddo
5533
5534        do k=1,3
5535          dXX_Ctab(k,i)=dXX_Ci(k)
5536          dXX_C1tab(k,i)=dXX_Ci1(k)
5537          dYY_Ctab(k,i)=dYY_Ci(k)
5538          dYY_C1tab(k,i)=dYY_Ci1(k)
5539          dZZ_Ctab(k,i)=dZZ_Ci(k)
5540          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5541          dXX_XYZtab(k,i)=dXX_XYZ(k)
5542          dYY_XYZtab(k,i)=dYY_XYZ(k)
5543          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5544        enddo
5545
5546        do k = 1,3
5547 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5548 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5549 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5550 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5551 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5552 c     &    dt_dci(k)
5553 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5554 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5555          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5556      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5557          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5558      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5559          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5560      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5561        enddo
5562 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5563 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5564
5565 C to check gradient call subroutine check_grad
5566
5567     1 continue
5568       enddo
5569       return
5570       end
5571 c------------------------------------------------------------------------------
5572       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5573       implicit none
5574       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5575      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5576       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5577      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5578      &   + x(10)*yy*zz
5579       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5580      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5581      & + x(20)*yy*zz
5582       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5583      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5584      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5585      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5586      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5587      &  +x(40)*xx*yy*zz
5588       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5589      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5590      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5591      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5592      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5593      &  +x(60)*xx*yy*zz
5594       dsc_i   = 0.743d0+x(61)
5595       dp2_i   = 1.9d0+x(62)
5596       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5597      &          *(xx*cost2+yy*sint2))
5598       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5599      &          *(xx*cost2-yy*sint2))
5600       s1=(1+x(63))/(0.1d0 + dscp1)
5601       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5602       s2=(1+x(65))/(0.1d0 + dscp2)
5603       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5604       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5605      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5606       enesc=sumene
5607       return
5608       end
5609 #endif
5610 c------------------------------------------------------------------------------
5611       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5612 C
5613 C This procedure calculates two-body contact function g(rij) and its derivative:
5614 C
5615 C           eps0ij                                     !       x < -1
5616 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5617 C            0                                         !       x > 1
5618 C
5619 C where x=(rij-r0ij)/delta
5620 C
5621 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5622 C
5623       implicit none
5624       double precision rij,r0ij,eps0ij,fcont,fprimcont
5625       double precision x,x2,x4,delta
5626 c     delta=0.02D0*r0ij
5627 c      delta=0.2D0*r0ij
5628       x=(rij-r0ij)/delta
5629       if (x.lt.-1.0D0) then
5630         fcont=eps0ij
5631         fprimcont=0.0D0
5632       else if (x.le.1.0D0) then
5633         x2=x*x
5634         x4=x2*x2
5635         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5636         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5637       else
5638         fcont=0.0D0
5639         fprimcont=0.0D0
5640       endif
5641       return
5642       end
5643 c------------------------------------------------------------------------------
5644       subroutine splinthet(theti,delta,ss,ssder)
5645       implicit real*8 (a-h,o-z)
5646       include 'DIMENSIONS'
5647       include 'COMMON.VAR'
5648       include 'COMMON.GEO'
5649       thetup=pi-delta
5650       thetlow=delta
5651       if (theti.gt.pipol) then
5652         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5653       else
5654         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5655         ssder=-ssder
5656       endif
5657       return
5658       end
5659 c------------------------------------------------------------------------------
5660       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5661       implicit none
5662       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5663       double precision ksi,ksi2,ksi3,a1,a2,a3
5664       a1=fprim0*delta/(f1-f0)
5665       a2=3.0d0-2.0d0*a1
5666       a3=a1-2.0d0
5667       ksi=(x-x0)/delta
5668       ksi2=ksi*ksi
5669       ksi3=ksi2*ksi
5670       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5671       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5672       return
5673       end
5674 c------------------------------------------------------------------------------
5675       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5676       implicit none
5677       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5678       double precision ksi,ksi2,ksi3,a1,a2,a3
5679       ksi=(x-x0)/delta
5680       ksi2=ksi*ksi
5681       ksi3=ksi2*ksi
5682       a1=fprim0x*delta
5683       a2=3*(f1x-f0x)-2*fprim0x*delta
5684       a3=fprim0x*delta-2*(f1x-f0x)
5685       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5686       return
5687       end
5688 C-----------------------------------------------------------------------------
5689 #ifdef CRYST_TOR
5690 C-----------------------------------------------------------------------------
5691       subroutine etor(etors,edihcnstr)
5692       implicit real*8 (a-h,o-z)
5693       include 'DIMENSIONS'
5694       include 'COMMON.VAR'
5695       include 'COMMON.GEO'
5696       include 'COMMON.LOCAL'
5697       include 'COMMON.TORSION'
5698       include 'COMMON.INTERACT'
5699       include 'COMMON.DERIV'
5700       include 'COMMON.CHAIN'
5701       include 'COMMON.NAMES'
5702       include 'COMMON.IOUNITS'
5703       include 'COMMON.FFIELD'
5704       include 'COMMON.TORCNSTR'
5705       include 'COMMON.CONTROL'
5706       logical lprn
5707 C Set lprn=.true. for debugging
5708       lprn=.false.
5709 c      lprn=.true.
5710       etors=0.0D0
5711       do i=iphi_start,iphi_end
5712       etors_ii=0.0D0
5713         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5714      &      .or. itype(i).eq.ntyp1) cycle
5715         itori=itortyp(itype(i-2))
5716         itori1=itortyp(itype(i-1))
5717         phii=phi(i)
5718         gloci=0.0D0
5719 C Proline-Proline pair is a special case...
5720         if (itori.eq.3 .and. itori1.eq.3) then
5721           if (phii.gt.-dwapi3) then
5722             cosphi=dcos(3*phii)
5723             fac=1.0D0/(1.0D0-cosphi)
5724             etorsi=v1(1,3,3)*fac
5725             etorsi=etorsi+etorsi
5726             etors=etors+etorsi-v1(1,3,3)
5727             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5728             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5729           endif
5730           do j=1,3
5731             v1ij=v1(j+1,itori,itori1)
5732             v2ij=v2(j+1,itori,itori1)
5733             cosphi=dcos(j*phii)
5734             sinphi=dsin(j*phii)
5735             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5736             if (energy_dec) etors_ii=etors_ii+
5737      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5738             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5739           enddo
5740         else
5741           do j=1,nterm_old
5742             v1ij=v1(j,itori,itori1)
5743             v2ij=v2(j,itori,itori1)
5744             cosphi=dcos(j*phii)
5745             sinphi=dsin(j*phii)
5746             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5747             if (energy_dec) etors_ii=etors_ii+
5748      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5749             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5750           enddo
5751         endif
5752         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5753              'etor',i,etors_ii
5754         if (lprn)
5755      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5756      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5757      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5758         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5759 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5760       enddo
5761 ! 6/20/98 - dihedral angle constraints
5762       edihcnstr=0.0d0
5763       do i=1,ndih_constr
5764         itori=idih_constr(i)
5765         phii=phi(itori)
5766         difi=phii-phi0(i)
5767         if (difi.gt.drange(i)) then
5768           difi=difi-drange(i)
5769           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5770           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5771         else if (difi.lt.-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         endif
5776 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5777 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5778       enddo
5779 !      write (iout,*) 'edihcnstr',edihcnstr
5780       return
5781       end
5782 c------------------------------------------------------------------------------
5783       subroutine etor_d(etors_d)
5784       etors_d=0.0d0
5785       return
5786       end
5787 c----------------------------------------------------------------------------
5788 #else
5789       subroutine etor(etors,edihcnstr)
5790       implicit real*8 (a-h,o-z)
5791       include 'DIMENSIONS'
5792       include 'COMMON.VAR'
5793       include 'COMMON.GEO'
5794       include 'COMMON.LOCAL'
5795       include 'COMMON.TORSION'
5796       include 'COMMON.INTERACT'
5797       include 'COMMON.DERIV'
5798       include 'COMMON.CHAIN'
5799       include 'COMMON.NAMES'
5800       include 'COMMON.IOUNITS'
5801       include 'COMMON.FFIELD'
5802       include 'COMMON.TORCNSTR'
5803       include 'COMMON.CONTROL'
5804       logical lprn
5805 C Set lprn=.true. for debugging
5806       lprn=.false.
5807 c      lprn=.true.
5808       etors=0.0D0
5809       do i=iphi_start,iphi_end
5810         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5811      &       .or. itype(i).eq.ntyp1) cycle
5812         etors_ii=0.0D0
5813          if (iabs(itype(i)).eq.20) then
5814          iblock=2
5815          else
5816          iblock=1
5817          endif
5818         itori=itortyp(itype(i-2))
5819         itori1=itortyp(itype(i-1))
5820         phii=phi(i)
5821         gloci=0.0D0
5822 C Regular cosine and sine terms
5823         do j=1,nterm(itori,itori1,iblock)
5824           v1ij=v1(j,itori,itori1,iblock)
5825           v2ij=v2(j,itori,itori1,iblock)
5826           cosphi=dcos(j*phii)
5827           sinphi=dsin(j*phii)
5828           etors=etors+v1ij*cosphi+v2ij*sinphi
5829           if (energy_dec) etors_ii=etors_ii+
5830      &                v1ij*cosphi+v2ij*sinphi
5831           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5832         enddo
5833 C Lorentz terms
5834 C                         v1
5835 C  E = SUM ----------------------------------- - v1
5836 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5837 C
5838         cosphi=dcos(0.5d0*phii)
5839         sinphi=dsin(0.5d0*phii)
5840         do j=1,nlor(itori,itori1,iblock)
5841           vl1ij=vlor1(j,itori,itori1)
5842           vl2ij=vlor2(j,itori,itori1)
5843           vl3ij=vlor3(j,itori,itori1)
5844           pom=vl2ij*cosphi+vl3ij*sinphi
5845           pom1=1.0d0/(pom*pom+1.0d0)
5846           etors=etors+vl1ij*pom1
5847           if (energy_dec) etors_ii=etors_ii+
5848      &                vl1ij*pom1
5849           pom=-pom*pom1*pom1
5850           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5851         enddo
5852 C Subtract the constant term
5853         etors=etors-v0(itori,itori1,iblock)
5854           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5855      &         'etor',i,etors_ii
5856         if (lprn)
5857      &  write (iout,'(2(a3,2x,i3,2x),2i3,f10.2,6f8.3/36x,6f8.3/)')
5858      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5859      &  rad2deg*phii,
5860      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5861         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5862 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5863       enddo
5864 ! 6/20/98 - dihedral angle constraints
5865       edihcnstr=0.0d0
5866 c      do i=1,ndih_constr
5867       do i=idihconstr_start,idihconstr_end
5868         itori=idih_constr(i)
5869         phii=phi(itori)
5870         difi=pinorm(phii-phi0(i))
5871         if (difi.gt.drange(i)) then
5872           difi=difi-drange(i)
5873           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5874           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5875         else if (difi.lt.-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
5880           difi=0.0
5881         endif
5882 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5883 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5884 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5885       enddo
5886 cd       write (iout,*) 'edihcnstr',edihcnstr
5887       return
5888       end
5889 c----------------------------------------------------------------------------
5890       subroutine etor_d(etors_d)
5891 C 6/23/01 Compute double torsional energy
5892       implicit real*8 (a-h,o-z)
5893       include 'DIMENSIONS'
5894       include 'COMMON.VAR'
5895       include 'COMMON.GEO'
5896       include 'COMMON.LOCAL'
5897       include 'COMMON.TORSION'
5898       include 'COMMON.INTERACT'
5899       include 'COMMON.DERIV'
5900       include 'COMMON.CHAIN'
5901       include 'COMMON.NAMES'
5902       include 'COMMON.IOUNITS'
5903       include 'COMMON.FFIELD'
5904       include 'COMMON.TORCNSTR'
5905       logical lprn
5906 C Set lprn=.true. for debugging
5907       lprn=.false.
5908 c     lprn=.true.
5909       etors_d=0.0D0
5910 c      write(iout,*) "a tu??"
5911       do i=iphid_start,iphid_end
5912         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5913      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5914         itori=itortyp(itype(i-2))
5915         itori1=itortyp(itype(i-1))
5916         itori2=itortyp(itype(i))
5917         phii=phi(i)
5918         phii1=phi(i+1)
5919         gloci1=0.0D0
5920         gloci2=0.0D0
5921         iblock=1
5922         if (iabs(itype(i+1)).eq.20) iblock=2
5923
5924 C Regular cosine and sine terms
5925         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5926           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5927           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5928           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5929           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5930           cosphi1=dcos(j*phii)
5931           sinphi1=dsin(j*phii)
5932           cosphi2=dcos(j*phii1)
5933           sinphi2=dsin(j*phii1)
5934           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5935      &     v2cij*cosphi2+v2sij*sinphi2
5936           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5937           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5938         enddo
5939         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5940           do l=1,k-1
5941             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5942             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5943             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5944             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5945             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5946             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5947             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5948             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5949             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5950      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5951             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5952      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5953             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5954      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5955           enddo
5956         enddo
5957         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5958         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5959       enddo
5960       return
5961       end
5962 #endif
5963 c------------------------------------------------------------------------------
5964       subroutine eback_sc_corr(esccor)
5965 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5966 c        conformational states; temporarily implemented as differences
5967 c        between UNRES torsional potentials (dependent on three types of
5968 c        residues) and the torsional potentials dependent on all 20 types
5969 c        of residues computed from AM1  energy surfaces of terminally-blocked
5970 c        amino-acid residues.
5971       implicit real*8 (a-h,o-z)
5972       include 'DIMENSIONS'
5973       include 'COMMON.VAR'
5974       include 'COMMON.GEO'
5975       include 'COMMON.LOCAL'
5976       include 'COMMON.TORSION'
5977       include 'COMMON.SCCOR'
5978       include 'COMMON.INTERACT'
5979       include 'COMMON.DERIV'
5980       include 'COMMON.CHAIN'
5981       include 'COMMON.NAMES'
5982       include 'COMMON.IOUNITS'
5983       include 'COMMON.FFIELD'
5984       include 'COMMON.CONTROL'
5985       logical lprn
5986 C Set lprn=.true. for debugging
5987       lprn=.false.
5988 c      lprn=.true.
5989 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5990       esccor=0.0D0
5991       do i=itau_start,itau_end
5992         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5993         esccor_ii=0.0D0
5994         isccori=isccortyp(itype(i-2))
5995         isccori1=isccortyp(itype(i-1))
5996 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5997         phii=phi(i)
5998         do intertyp=1,3 !intertyp
5999 cc Added 09 May 2012 (Adasko)
6000 cc  Intertyp means interaction type of backbone mainchain correlation:
6001 c   1 = SC...Ca...Ca...Ca
6002 c   2 = Ca...Ca...Ca...SC
6003 c   3 = SC...Ca...Ca...SCi
6004         gloci=0.0D0
6005         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6006      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6007      &      (itype(i-1).eq.ntyp1)))
6008      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6009      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6010      &     .or.(itype(i).eq.ntyp1)))
6011      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6012      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6013      &      (itype(i-3).eq.ntyp1)))) cycle
6014         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6015         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6016      & cycle
6017        do j=1,nterm_sccor(isccori,isccori1)
6018           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6019           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6020           cosphi=dcos(j*tauangle(intertyp,i))
6021           sinphi=dsin(j*tauangle(intertyp,i))
6022           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6023           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6024         enddo
6025 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6026         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6027         if (lprn)
6028      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6029      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6030      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6031      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6032         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6033        enddo !intertyp
6034       enddo
6035
6036       return
6037       end
6038 c----------------------------------------------------------------------------
6039       subroutine multibody(ecorr)
6040 C This subroutine calculates multi-body contributions to energy following
6041 C the idea of Skolnick et al. If side chains I and J make a contact and
6042 C at the same time side chains I+1 and J+1 make a contact, an extra
6043 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6044       implicit real*8 (a-h,o-z)
6045       include 'DIMENSIONS'
6046       include 'COMMON.IOUNITS'
6047       include 'COMMON.DERIV'
6048       include 'COMMON.INTERACT'
6049       include 'COMMON.CONTACTS'
6050       double precision gx(3),gx1(3)
6051       logical lprn
6052
6053 C Set lprn=.true. for debugging
6054       lprn=.false.
6055
6056       if (lprn) then
6057         write (iout,'(a)') 'Contact function values:'
6058         do i=nnt,nct-2
6059           write (iout,'(i2,20(1x,i2,f10.5))')
6060      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6061         enddo
6062       endif
6063       ecorr=0.0D0
6064       do i=nnt,nct
6065         do j=1,3
6066           gradcorr(j,i)=0.0D0
6067           gradxorr(j,i)=0.0D0
6068         enddo
6069       enddo
6070       do i=nnt,nct-2
6071
6072         DO ISHIFT = 3,4
6073
6074         i1=i+ishift
6075         num_conti=num_cont(i)
6076         num_conti1=num_cont(i1)
6077         do jj=1,num_conti
6078           j=jcont(jj,i)
6079           do kk=1,num_conti1
6080             j1=jcont(kk,i1)
6081             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6082 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6083 cd   &                   ' ishift=',ishift
6084 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6085 C The system gains extra energy.
6086               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6087             endif   ! j1==j+-ishift
6088           enddo     ! kk
6089         enddo       ! jj
6090
6091         ENDDO ! ISHIFT
6092
6093       enddo         ! i
6094       return
6095       end
6096 c------------------------------------------------------------------------------
6097       double precision function esccorr(i,j,k,l,jj,kk)
6098       implicit real*8 (a-h,o-z)
6099       include 'DIMENSIONS'
6100       include 'COMMON.IOUNITS'
6101       include 'COMMON.DERIV'
6102       include 'COMMON.INTERACT'
6103       include 'COMMON.CONTACTS'
6104       double precision gx(3),gx1(3)
6105       logical lprn
6106       lprn=.false.
6107       eij=facont(jj,i)
6108       ekl=facont(kk,k)
6109 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6110 C Calculate the multi-body contribution to energy.
6111 C Calculate multi-body contributions to the gradient.
6112 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6113 cd   & k,l,(gacont(m,kk,k),m=1,3)
6114       do m=1,3
6115         gx(m) =ekl*gacont(m,jj,i)
6116         gx1(m)=eij*gacont(m,kk,k)
6117         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6118         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6119         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6120         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6121       enddo
6122       do m=i,j-1
6123         do ll=1,3
6124           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6125         enddo
6126       enddo
6127       do m=k,l-1
6128         do ll=1,3
6129           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6130         enddo
6131       enddo
6132       esccorr=-eij*ekl
6133       return
6134       end
6135 c------------------------------------------------------------------------------
6136       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6137 C This subroutine calculates multi-body contributions to hydrogen-bonding
6138       implicit real*8 (a-h,o-z)
6139       include 'DIMENSIONS'
6140       include 'COMMON.IOUNITS'
6141 #ifdef MPI
6142       include "mpif.h"
6143       parameter (max_cont=maxconts)
6144       parameter (max_dim=26)
6145       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6146       double precision zapas(max_dim,maxconts,max_fg_procs),
6147      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6148       common /przechowalnia/ zapas
6149       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6150      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6151 #endif
6152       include 'COMMON.SETUP'
6153       include 'COMMON.FFIELD'
6154       include 'COMMON.DERIV'
6155       include 'COMMON.INTERACT'
6156       include 'COMMON.CONTACTS'
6157       include 'COMMON.CONTROL'
6158       include 'COMMON.LOCAL'
6159       double precision gx(3),gx1(3),time00
6160       logical lprn,ldone
6161
6162 C Set lprn=.true. for debugging
6163       lprn=.false.
6164 #ifdef MPI
6165       n_corr=0
6166       n_corr1=0
6167       if (nfgtasks.le.1) goto 30
6168       if (lprn) then
6169         write (iout,'(a)') 'Contact function values before RECEIVE:'
6170         do i=nnt,nct-2
6171           write (iout,'(2i3,50(1x,i2,f5.2))')
6172      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6173      &    j=1,num_cont_hb(i))
6174         enddo
6175       endif
6176       call flush(iout)
6177       do i=1,ntask_cont_from
6178         ncont_recv(i)=0
6179       enddo
6180       do i=1,ntask_cont_to
6181         ncont_sent(i)=0
6182       enddo
6183 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6184 c     & ntask_cont_to
6185 C Make the list of contacts to send to send to other procesors
6186 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6187 c      call flush(iout)
6188       do i=iturn3_start,iturn3_end
6189 c        write (iout,*) "make contact list turn3",i," num_cont",
6190 c     &    num_cont_hb(i)
6191         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6192       enddo
6193       do i=iturn4_start,iturn4_end
6194 c        write (iout,*) "make contact list turn4",i," num_cont",
6195 c     &   num_cont_hb(i)
6196         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6197       enddo
6198       do ii=1,nat_sent
6199         i=iat_sent(ii)
6200 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6201 c     &    num_cont_hb(i)
6202         do j=1,num_cont_hb(i)
6203         do k=1,4
6204           jjc=jcont_hb(j,i)
6205           iproc=iint_sent_local(k,jjc,ii)
6206 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6207           if (iproc.gt.0) then
6208             ncont_sent(iproc)=ncont_sent(iproc)+1
6209             nn=ncont_sent(iproc)
6210             zapas(1,nn,iproc)=i
6211             zapas(2,nn,iproc)=jjc
6212             zapas(3,nn,iproc)=facont_hb(j,i)
6213             zapas(4,nn,iproc)=ees0p(j,i)
6214             zapas(5,nn,iproc)=ees0m(j,i)
6215             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6216             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6217             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6218             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6219             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6220             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6221             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6222             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6223             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6224             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6225             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6226             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6227             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6228             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6229             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6230             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6231             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6232             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6233             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6234             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6235             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6236           endif
6237         enddo
6238         enddo
6239       enddo
6240       if (lprn) then
6241       write (iout,*)
6242      &  "Numbers of contacts to be sent to other processors",
6243      &  (ncont_sent(i),i=1,ntask_cont_to)
6244       write (iout,*) "Contacts sent"
6245       do ii=1,ntask_cont_to
6246         nn=ncont_sent(ii)
6247         iproc=itask_cont_to(ii)
6248         write (iout,*) nn," contacts to processor",iproc,
6249      &   " of CONT_TO_COMM group"
6250         do i=1,nn
6251           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6252         enddo
6253       enddo
6254       call flush(iout)
6255       endif
6256       CorrelType=477
6257       CorrelID=fg_rank+1
6258       CorrelType1=478
6259       CorrelID1=nfgtasks+fg_rank+1
6260       ireq=0
6261 C Receive the numbers of needed contacts from other processors
6262       do ii=1,ntask_cont_from
6263         iproc=itask_cont_from(ii)
6264         ireq=ireq+1
6265         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6266      &    FG_COMM,req(ireq),IERR)
6267       enddo
6268 c      write (iout,*) "IRECV ended"
6269 c      call flush(iout)
6270 C Send the number of contacts needed by other processors
6271       do ii=1,ntask_cont_to
6272         iproc=itask_cont_to(ii)
6273         ireq=ireq+1
6274         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6275      &    FG_COMM,req(ireq),IERR)
6276       enddo
6277 c      write (iout,*) "ISEND ended"
6278 c      write (iout,*) "number of requests (nn)",ireq
6279       call flush(iout)
6280       if (ireq.gt.0)
6281      &  call MPI_Waitall(ireq,req,status_array,ierr)
6282 c      write (iout,*)
6283 c     &  "Numbers of contacts to be received from other processors",
6284 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6285 c      call flush(iout)
6286 C Receive contacts
6287       ireq=0
6288       do ii=1,ntask_cont_from
6289         iproc=itask_cont_from(ii)
6290         nn=ncont_recv(ii)
6291 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6292 c     &   " of CONT_TO_COMM group"
6293         call flush(iout)
6294         if (nn.gt.0) then
6295           ireq=ireq+1
6296           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6297      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6298 c          write (iout,*) "ireq,req",ireq,req(ireq)
6299         endif
6300       enddo
6301 C Send the contacts to processors that need them
6302       do ii=1,ntask_cont_to
6303         iproc=itask_cont_to(ii)
6304         nn=ncont_sent(ii)
6305 c        write (iout,*) nn," contacts to processor",iproc,
6306 c     &   " of CONT_TO_COMM group"
6307         if (nn.gt.0) then
6308           ireq=ireq+1
6309           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6310      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6311 c          write (iout,*) "ireq,req",ireq,req(ireq)
6312 c          do i=1,nn
6313 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6314 c          enddo
6315         endif
6316       enddo
6317 c      write (iout,*) "number of requests (contacts)",ireq
6318 c      write (iout,*) "req",(req(i),i=1,4)
6319 c      call flush(iout)
6320       if (ireq.gt.0)
6321      & call MPI_Waitall(ireq,req,status_array,ierr)
6322       do iii=1,ntask_cont_from
6323         iproc=itask_cont_from(iii)
6324         nn=ncont_recv(iii)
6325         if (lprn) then
6326         write (iout,*) "Received",nn," contacts from processor",iproc,
6327      &   " of CONT_FROM_COMM group"
6328         call flush(iout)
6329         do i=1,nn
6330           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6331         enddo
6332         call flush(iout)
6333         endif
6334         do i=1,nn
6335           ii=zapas_recv(1,i,iii)
6336 c Flag the received contacts to prevent double-counting
6337           jj=-zapas_recv(2,i,iii)
6338 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6339 c          call flush(iout)
6340           nnn=num_cont_hb(ii)+1
6341           num_cont_hb(ii)=nnn
6342           jcont_hb(nnn,ii)=jj
6343           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6344           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6345           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6346           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6347           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6348           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6349           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6350           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6351           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6352           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6353           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6354           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6355           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6356           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6357           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6358           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6359           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6360           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6361           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6362           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6363           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6364           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6365           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6366           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6367         enddo
6368       enddo
6369       call flush(iout)
6370       if (lprn) then
6371         write (iout,'(a)') 'Contact function values after receive:'
6372         do i=nnt,nct-2
6373           write (iout,'(2i3,50(1x,i3,f5.2))')
6374      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6375      &    j=1,num_cont_hb(i))
6376         enddo
6377         call flush(iout)
6378       endif
6379    30 continue
6380 #endif
6381       if (lprn) then
6382         write (iout,'(a)') 'Contact function values:'
6383         do i=nnt,nct-2
6384           write (iout,'(2i3,50(1x,i3,f5.2))')
6385      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6386      &    j=1,num_cont_hb(i))
6387         enddo
6388       endif
6389       ecorr=0.0D0
6390 C Remove the loop below after debugging !!!
6391       do i=nnt,nct
6392         do j=1,3
6393           gradcorr(j,i)=0.0D0
6394           gradxorr(j,i)=0.0D0
6395         enddo
6396       enddo
6397 C Calculate the local-electrostatic correlation terms
6398       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6399         i1=i+1
6400         num_conti=num_cont_hb(i)
6401         num_conti1=num_cont_hb(i+1)
6402         do jj=1,num_conti
6403           j=jcont_hb(jj,i)
6404           jp=iabs(j)
6405           do kk=1,num_conti1
6406             j1=jcont_hb(kk,i1)
6407             jp1=iabs(j1)
6408 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6409 c     &         ' jj=',jj,' kk=',kk
6410             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6411      &          .or. j.lt.0 .and. j1.gt.0) .and.
6412      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6413 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6414 C The system gains extra energy.
6415               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6416               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6417      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6418               n_corr=n_corr+1
6419             else if (j1.eq.j) then
6420 C Contacts I-J and I-(J+1) occur simultaneously.
6421 C The system loses extra energy.
6422 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6423             endif
6424           enddo ! kk
6425           do kk=1,num_conti
6426             j1=jcont_hb(kk,i)
6427 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6428 c    &         ' jj=',jj,' kk=',kk
6429             if (j1.eq.j+1) then
6430 C Contacts I-J and (I+1)-J occur simultaneously.
6431 C The system loses extra energy.
6432 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6433             endif ! j1==j+1
6434           enddo ! kk
6435         enddo ! jj
6436       enddo ! i
6437       return
6438       end
6439 c------------------------------------------------------------------------------
6440       subroutine add_hb_contact(ii,jj,itask)
6441       implicit real*8 (a-h,o-z)
6442       include "DIMENSIONS"
6443       include "COMMON.IOUNITS"
6444       integer max_cont
6445       integer max_dim
6446       parameter (max_cont=maxconts)
6447       parameter (max_dim=26)
6448       include "COMMON.CONTACTS"
6449       double precision zapas(max_dim,maxconts,max_fg_procs),
6450      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6451       common /przechowalnia/ zapas
6452       integer i,j,ii,jj,iproc,itask(4),nn
6453 c      write (iout,*) "itask",itask
6454       do i=1,2
6455         iproc=itask(i)
6456         if (iproc.gt.0) then
6457           do j=1,num_cont_hb(ii)
6458             jjc=jcont_hb(j,ii)
6459 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6460             if (jjc.eq.jj) then
6461               ncont_sent(iproc)=ncont_sent(iproc)+1
6462               nn=ncont_sent(iproc)
6463               zapas(1,nn,iproc)=ii
6464               zapas(2,nn,iproc)=jjc
6465               zapas(3,nn,iproc)=facont_hb(j,ii)
6466               zapas(4,nn,iproc)=ees0p(j,ii)
6467               zapas(5,nn,iproc)=ees0m(j,ii)
6468               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6469               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6470               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6471               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6472               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6473               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6474               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6475               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6476               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6477               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6478               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6479               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6480               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6481               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6482               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6483               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6484               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6485               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6486               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6487               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6488               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6489               exit
6490             endif
6491           enddo
6492         endif
6493       enddo
6494       return
6495       end
6496 c------------------------------------------------------------------------------
6497       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6498      &  n_corr1)
6499 C This subroutine calculates multi-body contributions to hydrogen-bonding
6500       implicit real*8 (a-h,o-z)
6501       include 'DIMENSIONS'
6502       include 'COMMON.IOUNITS'
6503 #ifdef MPI
6504       include "mpif.h"
6505       parameter (max_cont=maxconts)
6506       parameter (max_dim=70)
6507       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6508       double precision zapas(max_dim,maxconts,max_fg_procs),
6509      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6510       common /przechowalnia/ zapas
6511       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6512      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6513 #endif
6514       include 'COMMON.SETUP'
6515       include 'COMMON.FFIELD'
6516       include 'COMMON.DERIV'
6517       include 'COMMON.LOCAL'
6518       include 'COMMON.INTERACT'
6519       include 'COMMON.CONTACTS'
6520       include 'COMMON.CHAIN'
6521       include 'COMMON.CONTROL'
6522       double precision gx(3),gx1(3)
6523       integer num_cont_hb_old(maxres)
6524       logical lprn,ldone
6525       double precision eello4,eello5,eelo6,eello_turn6
6526       external eello4,eello5,eello6,eello_turn6
6527 C Set lprn=.true. for debugging
6528       lprn=.false.
6529       eturn6=0.0d0
6530 #ifdef MPI
6531       do i=1,nres
6532         num_cont_hb_old(i)=num_cont_hb(i)
6533       enddo
6534       n_corr=0
6535       n_corr1=0
6536       if (nfgtasks.le.1) goto 30
6537       if (lprn) then
6538         write (iout,'(a)') 'Contact function values before RECEIVE:'
6539         do i=nnt,nct-2
6540           write (iout,'(2i3,50(1x,i2,f5.2))')
6541      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6542      &    j=1,num_cont_hb(i))
6543         enddo
6544       endif
6545       call flush(iout)
6546       do i=1,ntask_cont_from
6547         ncont_recv(i)=0
6548       enddo
6549       do i=1,ntask_cont_to
6550         ncont_sent(i)=0
6551       enddo
6552 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6553 c     & ntask_cont_to
6554 C Make the list of contacts to send to send to other procesors
6555       do i=iturn3_start,iturn3_end
6556 c        write (iout,*) "make contact list turn3",i," num_cont",
6557 c     &    num_cont_hb(i)
6558         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6559       enddo
6560       do i=iturn4_start,iturn4_end
6561 c        write (iout,*) "make contact list turn4",i," num_cont",
6562 c     &   num_cont_hb(i)
6563         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6564       enddo
6565       do ii=1,nat_sent
6566         i=iat_sent(ii)
6567 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6568 c     &    num_cont_hb(i)
6569         do j=1,num_cont_hb(i)
6570         do k=1,4
6571           jjc=jcont_hb(j,i)
6572           iproc=iint_sent_local(k,jjc,ii)
6573 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6574           if (iproc.ne.0) then
6575             ncont_sent(iproc)=ncont_sent(iproc)+1
6576             nn=ncont_sent(iproc)
6577             zapas(1,nn,iproc)=i
6578             zapas(2,nn,iproc)=jjc
6579             zapas(3,nn,iproc)=d_cont(j,i)
6580             ind=3
6581             do kk=1,3
6582               ind=ind+1
6583               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6584             enddo
6585             do kk=1,2
6586               do ll=1,2
6587                 ind=ind+1
6588                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6589               enddo
6590             enddo
6591             do jj=1,5
6592               do kk=1,3
6593                 do ll=1,2
6594                   do mm=1,2
6595                     ind=ind+1
6596                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6597                   enddo
6598                 enddo
6599               enddo
6600             enddo
6601           endif
6602         enddo
6603         enddo
6604       enddo
6605       if (lprn) then
6606       write (iout,*)
6607      &  "Numbers of contacts to be sent to other processors",
6608      &  (ncont_sent(i),i=1,ntask_cont_to)
6609       write (iout,*) "Contacts sent"
6610       do ii=1,ntask_cont_to
6611         nn=ncont_sent(ii)
6612         iproc=itask_cont_to(ii)
6613         write (iout,*) nn," contacts to processor",iproc,
6614      &   " of CONT_TO_COMM group"
6615         do i=1,nn
6616           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6617         enddo
6618       enddo
6619       call flush(iout)
6620       endif
6621       CorrelType=477
6622       CorrelID=fg_rank+1
6623       CorrelType1=478
6624       CorrelID1=nfgtasks+fg_rank+1
6625       ireq=0
6626 C Receive the numbers of needed contacts from other processors
6627       do ii=1,ntask_cont_from
6628         iproc=itask_cont_from(ii)
6629         ireq=ireq+1
6630         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6631      &    FG_COMM,req(ireq),IERR)
6632       enddo
6633 c      write (iout,*) "IRECV ended"
6634 c      call flush(iout)
6635 C Send the number of contacts needed by other processors
6636       do ii=1,ntask_cont_to
6637         iproc=itask_cont_to(ii)
6638         ireq=ireq+1
6639         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6640      &    FG_COMM,req(ireq),IERR)
6641       enddo
6642 c      write (iout,*) "ISEND ended"
6643 c      write (iout,*) "number of requests (nn)",ireq
6644       call flush(iout)
6645       if (ireq.gt.0)
6646      &  call MPI_Waitall(ireq,req,status_array,ierr)
6647 c      write (iout,*)
6648 c     &  "Numbers of contacts to be received from other processors",
6649 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6650 c      call flush(iout)
6651 C Receive contacts
6652       ireq=0
6653       do ii=1,ntask_cont_from
6654         iproc=itask_cont_from(ii)
6655         nn=ncont_recv(ii)
6656 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6657 c     &   " of CONT_TO_COMM group"
6658         call flush(iout)
6659         if (nn.gt.0) then
6660           ireq=ireq+1
6661           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6662      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6663 c          write (iout,*) "ireq,req",ireq,req(ireq)
6664         endif
6665       enddo
6666 C Send the contacts to processors that need them
6667       do ii=1,ntask_cont_to
6668         iproc=itask_cont_to(ii)
6669         nn=ncont_sent(ii)
6670 c        write (iout,*) nn," contacts to processor",iproc,
6671 c     &   " of CONT_TO_COMM group"
6672         if (nn.gt.0) then
6673           ireq=ireq+1
6674           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6675      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6676 c          write (iout,*) "ireq,req",ireq,req(ireq)
6677 c          do i=1,nn
6678 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6679 c          enddo
6680         endif
6681       enddo
6682 c      write (iout,*) "number of requests (contacts)",ireq
6683 c      write (iout,*) "req",(req(i),i=1,4)
6684 c      call flush(iout)
6685       if (ireq.gt.0)
6686      & call MPI_Waitall(ireq,req,status_array,ierr)
6687       do iii=1,ntask_cont_from
6688         iproc=itask_cont_from(iii)
6689         nn=ncont_recv(iii)
6690         if (lprn) then
6691         write (iout,*) "Received",nn," contacts from processor",iproc,
6692      &   " of CONT_FROM_COMM group"
6693         call flush(iout)
6694         do i=1,nn
6695           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6696         enddo
6697         call flush(iout)
6698         endif
6699         do i=1,nn
6700           ii=zapas_recv(1,i,iii)
6701 c Flag the received contacts to prevent double-counting
6702           jj=-zapas_recv(2,i,iii)
6703 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6704 c          call flush(iout)
6705           nnn=num_cont_hb(ii)+1
6706           num_cont_hb(ii)=nnn
6707           jcont_hb(nnn,ii)=jj
6708           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6709           ind=3
6710           do kk=1,3
6711             ind=ind+1
6712             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6713           enddo
6714           do kk=1,2
6715             do ll=1,2
6716               ind=ind+1
6717               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6718             enddo
6719           enddo
6720           do jj=1,5
6721             do kk=1,3
6722               do ll=1,2
6723                 do mm=1,2
6724                   ind=ind+1
6725                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6726                 enddo
6727               enddo
6728             enddo
6729           enddo
6730         enddo
6731       enddo
6732       call flush(iout)
6733       if (lprn) then
6734         write (iout,'(a)') 'Contact function values after receive:'
6735         do i=nnt,nct-2
6736           write (iout,'(2i3,50(1x,i3,5f6.3))')
6737      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6738      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6739         enddo
6740         call flush(iout)
6741       endif
6742    30 continue
6743 #endif
6744       if (lprn) then
6745         write (iout,'(a)') 'Contact function values:'
6746         do i=nnt,nct-2
6747           write (iout,'(2i3,50(1x,i2,5f6.3))')
6748      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6749      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6750         enddo
6751       endif
6752       ecorr=0.0D0
6753       ecorr5=0.0d0
6754       ecorr6=0.0d0
6755 C Remove the loop below after debugging !!!
6756       do i=nnt,nct
6757         do j=1,3
6758           gradcorr(j,i)=0.0D0
6759           gradxorr(j,i)=0.0D0
6760         enddo
6761       enddo
6762 C Calculate the dipole-dipole interaction energies
6763       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6764       do i=iatel_s,iatel_e+1
6765         num_conti=num_cont_hb(i)
6766         do jj=1,num_conti
6767           j=jcont_hb(jj,i)
6768 #ifdef MOMENT
6769           call dipole(i,j,jj)
6770 #endif
6771         enddo
6772       enddo
6773       endif
6774 C Calculate the local-electrostatic correlation terms
6775 c                write (iout,*) "gradcorr5 in eello5 before loop"
6776 c                do iii=1,nres
6777 c                  write (iout,'(i5,3f10.5)')
6778 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6779 c                enddo
6780       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6781 c        write (iout,*) "corr loop i",i
6782         i1=i+1
6783         num_conti=num_cont_hb(i)
6784         num_conti1=num_cont_hb(i+1)
6785         do jj=1,num_conti
6786           j=jcont_hb(jj,i)
6787           jp=iabs(j)
6788           do kk=1,num_conti1
6789             j1=jcont_hb(kk,i1)
6790             jp1=iabs(j1)
6791 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6792 c     &         ' jj=',jj,' kk=',kk
6793 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6794             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6795      &          .or. j.lt.0 .and. j1.gt.0) .and.
6796      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6797 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6798 C The system gains extra energy.
6799               n_corr=n_corr+1
6800               sqd1=dsqrt(d_cont(jj,i))
6801               sqd2=dsqrt(d_cont(kk,i1))
6802               sred_geom = sqd1*sqd2
6803               IF (sred_geom.lt.cutoff_corr) THEN
6804                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6805      &            ekont,fprimcont)
6806 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6807 cd     &         ' jj=',jj,' kk=',kk
6808                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6809                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6810                 do l=1,3
6811                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6812                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6813                 enddo
6814                 n_corr1=n_corr1+1
6815 cd               write (iout,*) 'sred_geom=',sred_geom,
6816 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6817 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6818 cd               write (iout,*) "g_contij",g_contij
6819 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6820 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6821                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6822                 if (wcorr4.gt.0.0d0)
6823      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6824                   if (energy_dec.and.wcorr4.gt.0.0d0)
6825      1                 write (iout,'(a6,4i5,0pf7.3)')
6826      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6827 c                write (iout,*) "gradcorr5 before eello5"
6828 c                do iii=1,nres
6829 c                  write (iout,'(i5,3f10.5)')
6830 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6831 c                enddo
6832                 if (wcorr5.gt.0.0d0)
6833      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6834 c                write (iout,*) "gradcorr5 after eello5"
6835 c                do iii=1,nres
6836 c                  write (iout,'(i5,3f10.5)')
6837 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6838 c                enddo
6839                   if (energy_dec.and.wcorr5.gt.0.0d0)
6840      1                 write (iout,'(a6,4i5,0pf7.3)')
6841      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6842 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6843 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6844                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6845      &               .or. wturn6.eq.0.0d0))then
6846 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6847                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6848                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6849      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6850 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6851 cd     &            'ecorr6=',ecorr6
6852 cd                write (iout,'(4e15.5)') sred_geom,
6853 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6854 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6855 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6856                 else if (wturn6.gt.0.0d0
6857      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6858 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6859                   eturn6=eturn6+eello_turn6(i,jj,kk)
6860                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6861      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6862 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6863                 endif
6864               ENDIF
6865 1111          continue
6866             endif
6867           enddo ! kk
6868         enddo ! jj
6869       enddo ! i
6870       do i=1,nres
6871         num_cont_hb(i)=num_cont_hb_old(i)
6872       enddo
6873 c                write (iout,*) "gradcorr5 in eello5"
6874 c                do iii=1,nres
6875 c                  write (iout,'(i5,3f10.5)')
6876 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6877 c                enddo
6878       return
6879       end
6880 c------------------------------------------------------------------------------
6881       subroutine add_hb_contact_eello(ii,jj,itask)
6882       implicit real*8 (a-h,o-z)
6883       include "DIMENSIONS"
6884       include "COMMON.IOUNITS"
6885       integer max_cont
6886       integer max_dim
6887       parameter (max_cont=maxconts)
6888       parameter (max_dim=70)
6889       include "COMMON.CONTACTS"
6890       double precision zapas(max_dim,maxconts,max_fg_procs),
6891      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6892       common /przechowalnia/ zapas
6893       integer i,j,ii,jj,iproc,itask(4),nn
6894 c      write (iout,*) "itask",itask
6895       do i=1,2
6896         iproc=itask(i)
6897         if (iproc.gt.0) then
6898           do j=1,num_cont_hb(ii)
6899             jjc=jcont_hb(j,ii)
6900 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6901             if (jjc.eq.jj) then
6902               ncont_sent(iproc)=ncont_sent(iproc)+1
6903               nn=ncont_sent(iproc)
6904               zapas(1,nn,iproc)=ii
6905               zapas(2,nn,iproc)=jjc
6906               zapas(3,nn,iproc)=d_cont(j,ii)
6907               ind=3
6908               do kk=1,3
6909                 ind=ind+1
6910                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6911               enddo
6912               do kk=1,2
6913                 do ll=1,2
6914                   ind=ind+1
6915                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6916                 enddo
6917               enddo
6918               do jj=1,5
6919                 do kk=1,3
6920                   do ll=1,2
6921                     do mm=1,2
6922                       ind=ind+1
6923                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6924                     enddo
6925                   enddo
6926                 enddo
6927               enddo
6928               exit
6929             endif
6930           enddo
6931         endif
6932       enddo
6933       return
6934       end
6935 c------------------------------------------------------------------------------
6936       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6937       implicit real*8 (a-h,o-z)
6938       include 'DIMENSIONS'
6939       include 'COMMON.IOUNITS'
6940       include 'COMMON.DERIV'
6941       include 'COMMON.INTERACT'
6942       include 'COMMON.CONTACTS'
6943       double precision gx(3),gx1(3)
6944       logical lprn
6945       lprn=.false.
6946       eij=facont_hb(jj,i)
6947       ekl=facont_hb(kk,k)
6948       ees0pij=ees0p(jj,i)
6949       ees0pkl=ees0p(kk,k)
6950       ees0mij=ees0m(jj,i)
6951       ees0mkl=ees0m(kk,k)
6952       ekont=eij*ekl
6953       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6954 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6955 C Following 4 lines for diagnostics.
6956 cd    ees0pkl=0.0D0
6957 cd    ees0pij=1.0D0
6958 cd    ees0mkl=0.0D0
6959 cd    ees0mij=1.0D0
6960 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6961 c     & 'Contacts ',i,j,
6962 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6963 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6964 c     & 'gradcorr_long'
6965 C Calculate the multi-body contribution to energy.
6966 c      ecorr=ecorr+ekont*ees
6967 C Calculate multi-body contributions to the gradient.
6968       coeffpees0pij=coeffp*ees0pij
6969       coeffmees0mij=coeffm*ees0mij
6970       coeffpees0pkl=coeffp*ees0pkl
6971       coeffmees0mkl=coeffm*ees0mkl
6972       do ll=1,3
6973 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6974         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6975      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6976      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6977         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6978      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6979      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6980 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6981         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6982      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6983      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6984         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6985      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6986      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6987         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6988      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6989      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6990         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6991         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6992         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6993      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6994      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6995         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6996         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6997 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6998       enddo
6999 c      write (iout,*)
7000 cgrad      do m=i+1,j-1
7001 cgrad        do ll=1,3
7002 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7003 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7004 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7005 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7006 cgrad        enddo
7007 cgrad      enddo
7008 cgrad      do m=k+1,l-1
7009 cgrad        do ll=1,3
7010 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7011 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7012 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7013 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7014 cgrad        enddo
7015 cgrad      enddo
7016 c      write (iout,*) "ehbcorr",ekont*ees
7017       ehbcorr=ekont*ees
7018       return
7019       end
7020 #ifdef MOMENT
7021 C---------------------------------------------------------------------------
7022       subroutine dipole(i,j,jj)
7023       implicit real*8 (a-h,o-z)
7024       include 'DIMENSIONS'
7025       include 'COMMON.IOUNITS'
7026       include 'COMMON.CHAIN'
7027       include 'COMMON.FFIELD'
7028       include 'COMMON.DERIV'
7029       include 'COMMON.INTERACT'
7030       include 'COMMON.CONTACTS'
7031       include 'COMMON.TORSION'
7032       include 'COMMON.VAR'
7033       include 'COMMON.GEO'
7034       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7035      &  auxmat(2,2)
7036       iti1 = itortyp(itype(i+1))
7037       if (j.lt.nres-1) then
7038         itj1 = itortyp(itype(j+1))
7039       else
7040         itj1=ntortyp+1
7041       endif
7042       do iii=1,2
7043         dipi(iii,1)=Ub2(iii,i)
7044         dipderi(iii)=Ub2der(iii,i)
7045         dipi(iii,2)=b1(iii,i+1)
7046         dipj(iii,1)=Ub2(iii,j)
7047         dipderj(iii)=Ub2der(iii,j)
7048         dipj(iii,2)=b1(iii,j+1)
7049       enddo
7050       kkk=0
7051       do iii=1,2
7052         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7053         do jjj=1,2
7054           kkk=kkk+1
7055           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7056         enddo
7057       enddo
7058       do kkk=1,5
7059         do lll=1,3
7060           mmm=0
7061           do iii=1,2
7062             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7063      &        auxvec(1))
7064             do jjj=1,2
7065               mmm=mmm+1
7066               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7067             enddo
7068           enddo
7069         enddo
7070       enddo
7071       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7072       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7073       do iii=1,2
7074         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7075       enddo
7076       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7077       do iii=1,2
7078         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7079       enddo
7080       return
7081       end
7082 #endif
7083 C---------------------------------------------------------------------------
7084       subroutine calc_eello(i,j,k,l,jj,kk)
7085 C
7086 C This subroutine computes matrices and vectors needed to calculate
7087 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7088 C
7089       implicit real*8 (a-h,o-z)
7090       include 'DIMENSIONS'
7091       include 'COMMON.IOUNITS'
7092       include 'COMMON.CHAIN'
7093       include 'COMMON.DERIV'
7094       include 'COMMON.INTERACT'
7095       include 'COMMON.CONTACTS'
7096       include 'COMMON.TORSION'
7097       include 'COMMON.VAR'
7098       include 'COMMON.GEO'
7099       include 'COMMON.FFIELD'
7100       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7101      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7102       logical lprn
7103       common /kutas/ lprn
7104 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7105 cd     & ' jj=',jj,' kk=',kk
7106 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7107 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7108 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7109       do iii=1,2
7110         do jjj=1,2
7111           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7112           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7113         enddo
7114       enddo
7115       call transpose2(aa1(1,1),aa1t(1,1))
7116       call transpose2(aa2(1,1),aa2t(1,1))
7117       do kkk=1,5
7118         do lll=1,3
7119           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7120      &      aa1tder(1,1,lll,kkk))
7121           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7122      &      aa2tder(1,1,lll,kkk))
7123         enddo
7124       enddo
7125       if (l.eq.j+1) then
7126 C parallel orientation of the two CA-CA-CA frames.
7127         if (i.gt.1) then
7128           iti=itortyp(itype(i))
7129         else
7130           iti=ntortyp+1
7131         endif
7132         itk1=itortyp(itype(k+1))
7133         itj=itortyp(itype(j))
7134         if (l.lt.nres-1) then
7135           itl1=itortyp(itype(l+1))
7136         else
7137           itl1=ntortyp+1
7138         endif
7139 C A1 kernel(j+1) A2T
7140 cd        do iii=1,2
7141 cd          write (iout,'(3f10.5,5x,3f10.5)')
7142 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7143 cd        enddo
7144         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7145      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7146      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7147 C Following matrices are needed only for 6-th order cumulants
7148         IF (wcorr6.gt.0.0d0) THEN
7149         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7150      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7151      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7152         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7153      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7154      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7155      &   ADtEAderx(1,1,1,1,1,1))
7156         lprn=.false.
7157         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7158      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7159      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7160      &   ADtEA1derx(1,1,1,1,1,1))
7161         ENDIF
7162 C End 6-th order cumulants
7163 cd        lprn=.false.
7164 cd        if (lprn) then
7165 cd        write (2,*) 'In calc_eello6'
7166 cd        do iii=1,2
7167 cd          write (2,*) 'iii=',iii
7168 cd          do kkk=1,5
7169 cd            write (2,*) 'kkk=',kkk
7170 cd            do jjj=1,2
7171 cd              write (2,'(3(2f10.5),5x)')
7172 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7173 cd            enddo
7174 cd          enddo
7175 cd        enddo
7176 cd        endif
7177         call transpose2(EUgder(1,1,k),auxmat(1,1))
7178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7179         call transpose2(EUg(1,1,k),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7181         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7182         do iii=1,2
7183           do kkk=1,5
7184             do lll=1,3
7185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7186      &          EAEAderx(1,1,lll,kkk,iii,1))
7187             enddo
7188           enddo
7189         enddo
7190 C A1T kernel(i+1) A2
7191         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7192      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7193      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7194 C Following matrices are needed only for 6-th order cumulants
7195         IF (wcorr6.gt.0.0d0) THEN
7196         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7197      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7198      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7199         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7200      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7201      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7202      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
7205      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7206      &   ADtEA1derx(1,1,1,1,1,2))
7207         ENDIF
7208 C End 6-th order cumulants
7209         call transpose2(EUgder(1,1,l),auxmat(1,1))
7210         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7211         call transpose2(EUg(1,1,l),auxmat(1,1))
7212         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7213         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7214         do iii=1,2
7215           do kkk=1,5
7216             do lll=1,3
7217               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7218      &          EAEAderx(1,1,lll,kkk,iii,2))
7219             enddo
7220           enddo
7221         enddo
7222 C AEAb1 and AEAb2
7223 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7224 C They are needed only when the fifth- or the sixth-order cumulants are
7225 C indluded.
7226         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7227         call transpose2(AEA(1,1,1),auxmat(1,1))
7228         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7229         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7230         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7231         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7232         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7233         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7234         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7235         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7236         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7237         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7238         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7239         call transpose2(AEA(1,1,2),auxmat(1,1))
7240         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7241         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7242         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7243         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7244         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7245         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7246         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7247         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7248         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7249         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7250         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7251 C Calculate the Cartesian derivatives of the vectors.
7252         do iii=1,2
7253           do kkk=1,5
7254             do lll=1,3
7255               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7256               call matvec2(auxmat(1,1),b1(1,i),
7257      &          AEAb1derx(1,lll,kkk,iii,1,1))
7258               call matvec2(auxmat(1,1),Ub2(1,i),
7259      &          AEAb2derx(1,lll,kkk,iii,1,1))
7260               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7261      &          AEAb1derx(1,lll,kkk,iii,2,1))
7262               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7263      &          AEAb2derx(1,lll,kkk,iii,2,1))
7264               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7265               call matvec2(auxmat(1,1),b1(1,j),
7266      &          AEAb1derx(1,lll,kkk,iii,1,2))
7267               call matvec2(auxmat(1,1),Ub2(1,j),
7268      &          AEAb2derx(1,lll,kkk,iii,1,2))
7269               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7270      &          AEAb1derx(1,lll,kkk,iii,2,2))
7271               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7272      &          AEAb2derx(1,lll,kkk,iii,2,2))
7273             enddo
7274           enddo
7275         enddo
7276         ENDIF
7277 C End vectors
7278       else
7279 C Antiparallel orientation of the two CA-CA-CA frames.
7280         if (i.gt.1) then
7281           iti=itortyp(itype(i))
7282         else
7283           iti=ntortyp+1
7284         endif
7285         itk1=itortyp(itype(k+1))
7286         itl=itortyp(itype(l))
7287         itj=itortyp(itype(j))
7288         if (j.lt.nres-1) then
7289           itj1=itortyp(itype(j+1))
7290         else
7291           itj1=ntortyp+1
7292         endif
7293 C A2 kernel(j-1)T A1T
7294         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7295      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7296      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7297 C Following matrices are needed only for 6-th order cumulants
7298         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7299      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7300         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7301      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7302      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7303         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7304      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7305      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7306      &   ADtEAderx(1,1,1,1,1,1))
7307         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7308      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7309      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7310      &   ADtEA1derx(1,1,1,1,1,1))
7311         ENDIF
7312 C End 6-th order cumulants
7313         call transpose2(EUgder(1,1,k),auxmat(1,1))
7314         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7315         call transpose2(EUg(1,1,k),auxmat(1,1))
7316         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7317         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7318         do iii=1,2
7319           do kkk=1,5
7320             do lll=1,3
7321               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7322      &          EAEAderx(1,1,lll,kkk,iii,1))
7323             enddo
7324           enddo
7325         enddo
7326 C A2T kernel(i+1)T A1
7327         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7328      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7329      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7330 C Following matrices are needed only for 6-th order cumulants
7331         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7332      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7333         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7334      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7335      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7336         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7337      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7338      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7339      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
7342      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7343      &   ADtEA1derx(1,1,1,1,1,2))
7344         ENDIF
7345 C End 6-th order cumulants
7346         call transpose2(EUgder(1,1,j),auxmat(1,1))
7347         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7348         call transpose2(EUg(1,1,j),auxmat(1,1))
7349         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7350         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7351         do iii=1,2
7352           do kkk=1,5
7353             do lll=1,3
7354               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7355      &          EAEAderx(1,1,lll,kkk,iii,2))
7356             enddo
7357           enddo
7358         enddo
7359 C AEAb1 and AEAb2
7360 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7361 C They are needed only when the fifth- or the sixth-order cumulants are
7362 C indluded.
7363         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7364      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7365         call transpose2(AEA(1,1,1),auxmat(1,1))
7366         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7367         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7368         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7369         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7370         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7371         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7372         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7373         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7374         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7375         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7376         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7377         call transpose2(AEA(1,1,2),auxmat(1,1))
7378         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7379         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7380         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7381         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7382         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7383         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7384         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7385         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7386         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7387         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7388         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7389 C Calculate the Cartesian derivatives of the vectors.
7390         do iii=1,2
7391           do kkk=1,5
7392             do lll=1,3
7393               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7394               call matvec2(auxmat(1,1),b1(1,i),
7395      &          AEAb1derx(1,lll,kkk,iii,1,1))
7396               call matvec2(auxmat(1,1),Ub2(1,i),
7397      &          AEAb2derx(1,lll,kkk,iii,1,1))
7398               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7399      &          AEAb1derx(1,lll,kkk,iii,2,1))
7400               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7401      &          AEAb2derx(1,lll,kkk,iii,2,1))
7402               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7403               call matvec2(auxmat(1,1),b1(1,l),
7404      &          AEAb1derx(1,lll,kkk,iii,1,2))
7405               call matvec2(auxmat(1,1),Ub2(1,l),
7406      &          AEAb2derx(1,lll,kkk,iii,1,2))
7407               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7408      &          AEAb1derx(1,lll,kkk,iii,2,2))
7409               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7410      &          AEAb2derx(1,lll,kkk,iii,2,2))
7411             enddo
7412           enddo
7413         enddo
7414         ENDIF
7415 C End vectors
7416       endif
7417       return
7418       end
7419 C---------------------------------------------------------------------------
7420       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7421      &  KK,KKderg,AKA,AKAderg,AKAderx)
7422       implicit none
7423       integer nderg
7424       logical transp
7425       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7426      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7427      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7428       integer iii,kkk,lll
7429       integer jjj,mmm
7430       logical lprn
7431       common /kutas/ lprn
7432       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7433       do iii=1,nderg
7434         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7435      &    AKAderg(1,1,iii))
7436       enddo
7437 cd      if (lprn) write (2,*) 'In kernel'
7438       do kkk=1,5
7439 cd        if (lprn) write (2,*) 'kkk=',kkk
7440         do lll=1,3
7441           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7442      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7443 cd          if (lprn) then
7444 cd            write (2,*) 'lll=',lll
7445 cd            write (2,*) 'iii=1'
7446 cd            do jjj=1,2
7447 cd              write (2,'(3(2f10.5),5x)')
7448 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7449 cd            enddo
7450 cd          endif
7451           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7452      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7453 cd          if (lprn) then
7454 cd            write (2,*) 'lll=',lll
7455 cd            write (2,*) 'iii=2'
7456 cd            do jjj=1,2
7457 cd              write (2,'(3(2f10.5),5x)')
7458 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7459 cd            enddo
7460 cd          endif
7461         enddo
7462       enddo
7463       return
7464       end
7465 C---------------------------------------------------------------------------
7466       double precision function eello4(i,j,k,l,jj,kk)
7467       implicit real*8 (a-h,o-z)
7468       include 'DIMENSIONS'
7469       include 'COMMON.IOUNITS'
7470       include 'COMMON.CHAIN'
7471       include 'COMMON.DERIV'
7472       include 'COMMON.INTERACT'
7473       include 'COMMON.CONTACTS'
7474       include 'COMMON.TORSION'
7475       include 'COMMON.VAR'
7476       include 'COMMON.GEO'
7477       double precision pizda(2,2),ggg1(3),ggg2(3)
7478 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7479 cd        eello4=0.0d0
7480 cd        return
7481 cd      endif
7482 cd      print *,'eello4:',i,j,k,l,jj,kk
7483 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7484 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7485 cold      eij=facont_hb(jj,i)
7486 cold      ekl=facont_hb(kk,k)
7487 cold      ekont=eij*ekl
7488       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7489 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7490       gcorr_loc(k-1)=gcorr_loc(k-1)
7491      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7492       if (l.eq.j+1) then
7493         gcorr_loc(l-1)=gcorr_loc(l-1)
7494      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7495       else
7496         gcorr_loc(j-1)=gcorr_loc(j-1)
7497      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7498       endif
7499       do iii=1,2
7500         do kkk=1,5
7501           do lll=1,3
7502             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7503      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7504 cd            derx(lll,kkk,iii)=0.0d0
7505           enddo
7506         enddo
7507       enddo
7508 cd      gcorr_loc(l-1)=0.0d0
7509 cd      gcorr_loc(j-1)=0.0d0
7510 cd      gcorr_loc(k-1)=0.0d0
7511 cd      eel4=1.0d0
7512 cd      write (iout,*)'Contacts have occurred for peptide groups',
7513 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7514 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7515       if (j.lt.nres-1) then
7516         j1=j+1
7517         j2=j-1
7518       else
7519         j1=j-1
7520         j2=j-2
7521       endif
7522       if (l.lt.nres-1) then
7523         l1=l+1
7524         l2=l-1
7525       else
7526         l1=l-1
7527         l2=l-2
7528       endif
7529       do ll=1,3
7530 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7531 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7532         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7533         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7534 cgrad        ghalf=0.5d0*ggg1(ll)
7535         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7536         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7537         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7538         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7539         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7540         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7541 cgrad        ghalf=0.5d0*ggg2(ll)
7542         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7543         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7544         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7545         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7546         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7547         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7548       enddo
7549 cgrad      do m=i+1,j-1
7550 cgrad        do ll=1,3
7551 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7552 cgrad        enddo
7553 cgrad      enddo
7554 cgrad      do m=k+1,l-1
7555 cgrad        do ll=1,3
7556 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7557 cgrad        enddo
7558 cgrad      enddo
7559 cgrad      do m=i+2,j2
7560 cgrad        do ll=1,3
7561 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7562 cgrad        enddo
7563 cgrad      enddo
7564 cgrad      do m=k+2,l2
7565 cgrad        do ll=1,3
7566 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7567 cgrad        enddo
7568 cgrad      enddo
7569 cd      do iii=1,nres-3
7570 cd        write (2,*) iii,gcorr_loc(iii)
7571 cd      enddo
7572       eello4=ekont*eel4
7573 cd      write (2,*) 'ekont',ekont
7574 cd      write (iout,*) 'eello4',ekont*eel4
7575       return
7576       end
7577 C---------------------------------------------------------------------------
7578       double precision function eello5(i,j,k,l,jj,kk)
7579       implicit real*8 (a-h,o-z)
7580       include 'DIMENSIONS'
7581       include 'COMMON.IOUNITS'
7582       include 'COMMON.CHAIN'
7583       include 'COMMON.DERIV'
7584       include 'COMMON.INTERACT'
7585       include 'COMMON.CONTACTS'
7586       include 'COMMON.TORSION'
7587       include 'COMMON.VAR'
7588       include 'COMMON.GEO'
7589       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7590       double precision ggg1(3),ggg2(3)
7591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7592 C                                                                              C
7593 C                            Parallel chains                                   C
7594 C                                                                              C
7595 C          o             o                   o             o                   C
7596 C         /l\           / \             \   / \           / \   /              C
7597 C        /   \         /   \             \ /   \         /   \ /               C
7598 C       j| o |l1       | o |              o| o |         | o |o                C
7599 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7600 C      \i/   \         /   \ /             /   \         /   \                 C
7601 C       o    k1             o                                                  C
7602 C         (I)          (II)                (III)          (IV)                 C
7603 C                                                                              C
7604 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7605 C                                                                              C
7606 C                            Antiparallel chains                               C
7607 C                                                                              C
7608 C          o             o                   o             o                   C
7609 C         /j\           / \             \   / \           / \   /              C
7610 C        /   \         /   \             \ /   \         /   \ /               C
7611 C      j1| o |l        | o |              o| o |         | o |o                C
7612 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7613 C      \i/   \         /   \ /             /   \         /   \                 C
7614 C       o     k1            o                                                  C
7615 C         (I)          (II)                (III)          (IV)                 C
7616 C                                                                              C
7617 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7618 C                                                                              C
7619 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7620 C                                                                              C
7621 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7622 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7623 cd        eello5=0.0d0
7624 cd        return
7625 cd      endif
7626 cd      write (iout,*)
7627 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7628 cd     &   ' and',k,l
7629       itk=itortyp(itype(k))
7630       itl=itortyp(itype(l))
7631       itj=itortyp(itype(j))
7632       eello5_1=0.0d0
7633       eello5_2=0.0d0
7634       eello5_3=0.0d0
7635       eello5_4=0.0d0
7636 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7637 cd     &   eel5_3_num,eel5_4_num)
7638       do iii=1,2
7639         do kkk=1,5
7640           do lll=1,3
7641             derx(lll,kkk,iii)=0.0d0
7642           enddo
7643         enddo
7644       enddo
7645 cd      eij=facont_hb(jj,i)
7646 cd      ekl=facont_hb(kk,k)
7647 cd      ekont=eij*ekl
7648 cd      write (iout,*)'Contacts have occurred for peptide groups',
7649 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7650 cd      goto 1111
7651 C Contribution from the graph I.
7652 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7653 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7654       call transpose2(EUg(1,1,k),auxmat(1,1))
7655       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7656       vv(1)=pizda(1,1)-pizda(2,2)
7657       vv(2)=pizda(1,2)+pizda(2,1)
7658       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7659      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7660 C Explicit gradient in virtual-dihedral angles.
7661       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7662      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7663      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7664       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7665       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7666       vv(1)=pizda(1,1)-pizda(2,2)
7667       vv(2)=pizda(1,2)+pizda(2,1)
7668       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7669      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7670      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7671       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)-pizda(2,2)
7673       vv(2)=pizda(1,2)+pizda(2,1)
7674       if (l.eq.j+1) then
7675         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7676      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7677      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7678       else
7679         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7680      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7681      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7682       endif
7683 C Cartesian gradient
7684       do iii=1,2
7685         do kkk=1,5
7686           do lll=1,3
7687             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7688      &        pizda(1,1))
7689             vv(1)=pizda(1,1)-pizda(2,2)
7690             vv(2)=pizda(1,2)+pizda(2,1)
7691             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7692      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7693      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7694           enddo
7695         enddo
7696       enddo
7697 c      goto 1112
7698 c1111  continue
7699 C Contribution from graph II
7700       call transpose2(EE(1,1,itk),auxmat(1,1))
7701       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7702       vv(1)=pizda(1,1)+pizda(2,2)
7703       vv(2)=pizda(2,1)-pizda(1,2)
7704       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7705      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7706 C Explicit gradient in virtual-dihedral angles.
7707       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7708      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7709       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7710       vv(1)=pizda(1,1)+pizda(2,2)
7711       vv(2)=pizda(2,1)-pizda(1,2)
7712       if (l.eq.j+1) then
7713         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7714      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7715      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7716       else
7717         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7718      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7719      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7720       endif
7721 C Cartesian gradient
7722       do iii=1,2
7723         do kkk=1,5
7724           do lll=1,3
7725             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7726      &        pizda(1,1))
7727             vv(1)=pizda(1,1)+pizda(2,2)
7728             vv(2)=pizda(2,1)-pizda(1,2)
7729             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7730      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7731      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7732           enddo
7733         enddo
7734       enddo
7735 cd      goto 1112
7736 cd1111  continue
7737       if (l.eq.j+1) then
7738 cd        goto 1110
7739 C Parallel orientation
7740 C Contribution from graph III
7741         call transpose2(EUg(1,1,l),auxmat(1,1))
7742         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7743         vv(1)=pizda(1,1)-pizda(2,2)
7744         vv(2)=pizda(1,2)+pizda(2,1)
7745         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7746      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7747 C Explicit gradient in virtual-dihedral angles.
7748         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7749      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7750      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7751         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7752         vv(1)=pizda(1,1)-pizda(2,2)
7753         vv(2)=pizda(1,2)+pizda(2,1)
7754         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7755      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7756      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7757         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7758         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7759         vv(1)=pizda(1,1)-pizda(2,2)
7760         vv(2)=pizda(1,2)+pizda(2,1)
7761         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7762      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7763      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7764 C Cartesian gradient
7765         do iii=1,2
7766           do kkk=1,5
7767             do lll=1,3
7768               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7769      &          pizda(1,1))
7770               vv(1)=pizda(1,1)-pizda(2,2)
7771               vv(2)=pizda(1,2)+pizda(2,1)
7772               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7773      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7774      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7775             enddo
7776           enddo
7777         enddo
7778 cd        goto 1112
7779 C Contribution from graph IV
7780 cd1110    continue
7781         call transpose2(EE(1,1,itl),auxmat(1,1))
7782         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7783         vv(1)=pizda(1,1)+pizda(2,2)
7784         vv(2)=pizda(2,1)-pizda(1,2)
7785         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7786      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7787 C Explicit gradient in virtual-dihedral angles.
7788         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7789      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7790         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7791         vv(1)=pizda(1,1)+pizda(2,2)
7792         vv(2)=pizda(2,1)-pizda(1,2)
7793         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7794      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7795      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7796 C Cartesian gradient
7797         do iii=1,2
7798           do kkk=1,5
7799             do lll=1,3
7800               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7801      &          pizda(1,1))
7802               vv(1)=pizda(1,1)+pizda(2,2)
7803               vv(2)=pizda(2,1)-pizda(1,2)
7804               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7805      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7806      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7807             enddo
7808           enddo
7809         enddo
7810       else
7811 C Antiparallel orientation
7812 C Contribution from graph III
7813 c        goto 1110
7814         call transpose2(EUg(1,1,j),auxmat(1,1))
7815         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7816         vv(1)=pizda(1,1)-pizda(2,2)
7817         vv(2)=pizda(1,2)+pizda(2,1)
7818         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7819      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7820 C Explicit gradient in virtual-dihedral angles.
7821         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7822      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7823      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7824         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7825         vv(1)=pizda(1,1)-pizda(2,2)
7826         vv(2)=pizda(1,2)+pizda(2,1)
7827         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7828      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7829      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7830         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7831         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7832         vv(1)=pizda(1,1)-pizda(2,2)
7833         vv(2)=pizda(1,2)+pizda(2,1)
7834         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7835      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7836      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7837 C Cartesian gradient
7838         do iii=1,2
7839           do kkk=1,5
7840             do lll=1,3
7841               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7842      &          pizda(1,1))
7843               vv(1)=pizda(1,1)-pizda(2,2)
7844               vv(2)=pizda(1,2)+pizda(2,1)
7845               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7846      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7847      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7848             enddo
7849           enddo
7850         enddo
7851 cd        goto 1112
7852 C Contribution from graph IV
7853 1110    continue
7854         call transpose2(EE(1,1,itj),auxmat(1,1))
7855         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7856         vv(1)=pizda(1,1)+pizda(2,2)
7857         vv(2)=pizda(2,1)-pizda(1,2)
7858         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7859      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7860 C Explicit gradient in virtual-dihedral angles.
7861         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7862      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7863         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7864         vv(1)=pizda(1,1)+pizda(2,2)
7865         vv(2)=pizda(2,1)-pizda(1,2)
7866         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7867      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7868      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7869 C Cartesian gradient
7870         do iii=1,2
7871           do kkk=1,5
7872             do lll=1,3
7873               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7874      &          pizda(1,1))
7875               vv(1)=pizda(1,1)+pizda(2,2)
7876               vv(2)=pizda(2,1)-pizda(1,2)
7877               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7878      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7879      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7880             enddo
7881           enddo
7882         enddo
7883       endif
7884 1112  continue
7885       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7886 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7887 cd        write (2,*) 'ijkl',i,j,k,l
7888 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7889 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7890 cd      endif
7891 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7892 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7893 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7894 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7895       if (j.lt.nres-1) then
7896         j1=j+1
7897         j2=j-1
7898       else
7899         j1=j-1
7900         j2=j-2
7901       endif
7902       if (l.lt.nres-1) then
7903         l1=l+1
7904         l2=l-1
7905       else
7906         l1=l-1
7907         l2=l-2
7908       endif
7909 cd      eij=1.0d0
7910 cd      ekl=1.0d0
7911 cd      ekont=1.0d0
7912 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7913 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7914 C        summed up outside the subrouine as for the other subroutines
7915 C        handling long-range interactions. The old code is commented out
7916 C        with "cgrad" to keep track of changes.
7917       do ll=1,3
7918 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7919 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7920         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7921         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7922 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7923 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7924 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7925 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7926 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7927 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7928 c     &   gradcorr5ij,
7929 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7930 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7931 cgrad        ghalf=0.5d0*ggg1(ll)
7932 cd        ghalf=0.0d0
7933         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7934         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7935         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7936         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7937         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7938         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7939 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7940 cgrad        ghalf=0.5d0*ggg2(ll)
7941 cd        ghalf=0.0d0
7942         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7943         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7944         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7945         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7946         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7947         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7948       enddo
7949 cd      goto 1112
7950 cgrad      do m=i+1,j-1
7951 cgrad        do ll=1,3
7952 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7953 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7954 cgrad        enddo
7955 cgrad      enddo
7956 cgrad      do m=k+1,l-1
7957 cgrad        do ll=1,3
7958 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7959 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7960 cgrad        enddo
7961 cgrad      enddo
7962 c1112  continue
7963 cgrad      do m=i+2,j2
7964 cgrad        do ll=1,3
7965 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7966 cgrad        enddo
7967 cgrad      enddo
7968 cgrad      do m=k+2,l2
7969 cgrad        do ll=1,3
7970 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7971 cgrad        enddo
7972 cgrad      enddo
7973 cd      do iii=1,nres-3
7974 cd        write (2,*) iii,g_corr5_loc(iii)
7975 cd      enddo
7976       eello5=ekont*eel5
7977 cd      write (2,*) 'ekont',ekont
7978 cd      write (iout,*) 'eello5',ekont*eel5
7979       return
7980       end
7981 c--------------------------------------------------------------------------
7982       double precision function eello6(i,j,k,l,jj,kk)
7983       implicit real*8 (a-h,o-z)
7984       include 'DIMENSIONS'
7985       include 'COMMON.IOUNITS'
7986       include 'COMMON.CHAIN'
7987       include 'COMMON.DERIV'
7988       include 'COMMON.INTERACT'
7989       include 'COMMON.CONTACTS'
7990       include 'COMMON.TORSION'
7991       include 'COMMON.VAR'
7992       include 'COMMON.GEO'
7993       include 'COMMON.FFIELD'
7994       double precision ggg1(3),ggg2(3)
7995 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7996 cd        eello6=0.0d0
7997 cd        return
7998 cd      endif
7999 cd      write (iout,*)
8000 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8001 cd     &   ' and',k,l
8002       eello6_1=0.0d0
8003       eello6_2=0.0d0
8004       eello6_3=0.0d0
8005       eello6_4=0.0d0
8006       eello6_5=0.0d0
8007       eello6_6=0.0d0
8008 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8009 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8010       do iii=1,2
8011         do kkk=1,5
8012           do lll=1,3
8013             derx(lll,kkk,iii)=0.0d0
8014           enddo
8015         enddo
8016       enddo
8017 cd      eij=facont_hb(jj,i)
8018 cd      ekl=facont_hb(kk,k)
8019 cd      ekont=eij*ekl
8020 cd      eij=1.0d0
8021 cd      ekl=1.0d0
8022 cd      ekont=1.0d0
8023       if (l.eq.j+1) then
8024         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8025         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8026         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8027         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8028         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8029         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8030       else
8031         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8032         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8033         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8034         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8035         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8036           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8037         else
8038           eello6_5=0.0d0
8039         endif
8040         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8041       endif
8042 C If turn contributions are considered, they will be handled separately.
8043       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8044 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8045 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8046 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8047 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8048 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8049 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8050 cd      goto 1112
8051       if (j.lt.nres-1) then
8052         j1=j+1
8053         j2=j-1
8054       else
8055         j1=j-1
8056         j2=j-2
8057       endif
8058       if (l.lt.nres-1) then
8059         l1=l+1
8060         l2=l-1
8061       else
8062         l1=l-1
8063         l2=l-2
8064       endif
8065       do ll=1,3
8066 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8067 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8068 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8069 cgrad        ghalf=0.5d0*ggg1(ll)
8070 cd        ghalf=0.0d0
8071         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8072         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8073         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8074         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8075         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8076         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8077         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8078         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8079 cgrad        ghalf=0.5d0*ggg2(ll)
8080 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8081 cd        ghalf=0.0d0
8082         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8083         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8084         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8085         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8086         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8087         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8088       enddo
8089 cd      goto 1112
8090 cgrad      do m=i+1,j-1
8091 cgrad        do ll=1,3
8092 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8093 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8094 cgrad        enddo
8095 cgrad      enddo
8096 cgrad      do m=k+1,l-1
8097 cgrad        do ll=1,3
8098 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8099 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8100 cgrad        enddo
8101 cgrad      enddo
8102 cgrad1112  continue
8103 cgrad      do m=i+2,j2
8104 cgrad        do ll=1,3
8105 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8106 cgrad        enddo
8107 cgrad      enddo
8108 cgrad      do m=k+2,l2
8109 cgrad        do ll=1,3
8110 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8111 cgrad        enddo
8112 cgrad      enddo
8113 cd      do iii=1,nres-3
8114 cd        write (2,*) iii,g_corr6_loc(iii)
8115 cd      enddo
8116       eello6=ekont*eel6
8117 cd      write (2,*) 'ekont',ekont
8118 cd      write (iout,*) 'eello6',ekont*eel6
8119       return
8120       end
8121 c--------------------------------------------------------------------------
8122       double precision function eello6_graph1(i,j,k,l,imat,swap)
8123       implicit real*8 (a-h,o-z)
8124       include 'DIMENSIONS'
8125       include 'COMMON.IOUNITS'
8126       include 'COMMON.CHAIN'
8127       include 'COMMON.DERIV'
8128       include 'COMMON.INTERACT'
8129       include 'COMMON.CONTACTS'
8130       include 'COMMON.TORSION'
8131       include 'COMMON.VAR'
8132       include 'COMMON.GEO'
8133       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8134       logical swap
8135       logical lprn
8136       common /kutas/ lprn
8137 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8138 C                                                                              C
8139 C      Parallel       Antiparallel                                             C
8140 C                                                                              C
8141 C          o             o                                                     C
8142 C         /l\           /j\                                                    C
8143 C        /   \         /   \                                                   C
8144 C       /| o |         | o |\                                                  C
8145 C     \ j|/k\|  /   \  |/k\|l /                                                C
8146 C      \ /   \ /     \ /   \ /                                                 C
8147 C       o     o       o     o                                                  C
8148 C       i             i                                                        C
8149 C                                                                              C
8150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8151       itk=itortyp(itype(k))
8152       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8153       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8154       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8155       call transpose2(EUgC(1,1,k),auxmat(1,1))
8156       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8157       vv1(1)=pizda1(1,1)-pizda1(2,2)
8158       vv1(2)=pizda1(1,2)+pizda1(2,1)
8159       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8160       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8161       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8162       s5=scalar2(vv(1),Dtobr2(1,i))
8163 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8164       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8165       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8166      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8167      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8168      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8169      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8170      & +scalar2(vv(1),Dtobr2der(1,i)))
8171       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8172       vv1(1)=pizda1(1,1)-pizda1(2,2)
8173       vv1(2)=pizda1(1,2)+pizda1(2,1)
8174       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8175       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8176       if (l.eq.j+1) then
8177         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8178      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8179      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8180      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8181      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8182       else
8183         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8184      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8185      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8186      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8187      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8188       endif
8189       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8190       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8191       vv1(1)=pizda1(1,1)-pizda1(2,2)
8192       vv1(2)=pizda1(1,2)+pizda1(2,1)
8193       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8194      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8195      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8196      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8197       do iii=1,2
8198         if (swap) then
8199           ind=3-iii
8200         else
8201           ind=iii
8202         endif
8203         do kkk=1,5
8204           do lll=1,3
8205             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8206             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8207             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8208             call transpose2(EUgC(1,1,k),auxmat(1,1))
8209             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8210      &        pizda1(1,1))
8211             vv1(1)=pizda1(1,1)-pizda1(2,2)
8212             vv1(2)=pizda1(1,2)+pizda1(2,1)
8213             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8214             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8215      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8216             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8217      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8218             s5=scalar2(vv(1),Dtobr2(1,i))
8219             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8220           enddo
8221         enddo
8222       enddo
8223       return
8224       end
8225 c----------------------------------------------------------------------------
8226       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8227       implicit real*8 (a-h,o-z)
8228       include 'DIMENSIONS'
8229       include 'COMMON.IOUNITS'
8230       include 'COMMON.CHAIN'
8231       include 'COMMON.DERIV'
8232       include 'COMMON.INTERACT'
8233       include 'COMMON.CONTACTS'
8234       include 'COMMON.TORSION'
8235       include 'COMMON.VAR'
8236       include 'COMMON.GEO'
8237       logical swap
8238       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8239      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8240       logical lprn
8241       common /kutas/ lprn
8242 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8243 C                                                                              C
8244 C      Parallel       Antiparallel                                             C
8245 C                                                                              C
8246 C          o             o                                                     C
8247 C     \   /l\           /j\   /                                                C
8248 C      \ /   \         /   \ /                                                 C
8249 C       o| o |         | o |o                                                  C
8250 C     \ j|/k\|      \  |/k\|l                                                  C
8251 C      \ /   \       \ /   \                                                   C
8252 C       o             o                                                        C
8253 C       i             i                                                        C
8254 C                                                                              C
8255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8256 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8257 C AL 7/4/01 s1 would occur in the sixth-order moment,
8258 C           but not in a cluster cumulant
8259 #ifdef MOMENT
8260       s1=dip(1,jj,i)*dip(1,kk,k)
8261 #endif
8262       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8263       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8264       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8265       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8266       call transpose2(EUg(1,1,k),auxmat(1,1))
8267       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8268       vv(1)=pizda(1,1)-pizda(2,2)
8269       vv(2)=pizda(1,2)+pizda(2,1)
8270       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8271 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8272 #ifdef MOMENT
8273       eello6_graph2=-(s1+s2+s3+s4)
8274 #else
8275       eello6_graph2=-(s2+s3+s4)
8276 #endif
8277 c      eello6_graph2=-s3
8278 C Derivatives in gamma(i-1)
8279       if (i.gt.1) then
8280 #ifdef MOMENT
8281         s1=dipderg(1,jj,i)*dip(1,kk,k)
8282 #endif
8283         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8284         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8285         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8286         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8287 #ifdef MOMENT
8288         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8289 #else
8290         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8291 #endif
8292 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8293       endif
8294 C Derivatives in gamma(k-1)
8295 #ifdef MOMENT
8296       s1=dip(1,jj,i)*dipderg(1,kk,k)
8297 #endif
8298       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8299       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8300       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8301       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8302       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8303       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8304       vv(1)=pizda(1,1)-pizda(2,2)
8305       vv(2)=pizda(1,2)+pizda(2,1)
8306       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8307 #ifdef MOMENT
8308       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8309 #else
8310       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8311 #endif
8312 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8313 C Derivatives in gamma(j-1) or gamma(l-1)
8314       if (j.gt.1) then
8315 #ifdef MOMENT
8316         s1=dipderg(3,jj,i)*dip(1,kk,k)
8317 #endif
8318         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8319         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8320         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8321         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8322         vv(1)=pizda(1,1)-pizda(2,2)
8323         vv(2)=pizda(1,2)+pizda(2,1)
8324         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8325 #ifdef MOMENT
8326         if (swap) then
8327           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8328         else
8329           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8330         endif
8331 #endif
8332         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8333 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8334       endif
8335 C Derivatives in gamma(l-1) or gamma(j-1)
8336       if (l.gt.1) then
8337 #ifdef MOMENT
8338         s1=dip(1,jj,i)*dipderg(3,kk,k)
8339 #endif
8340         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8341         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8342         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8343         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8344         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8345         vv(1)=pizda(1,1)-pizda(2,2)
8346         vv(2)=pizda(1,2)+pizda(2,1)
8347         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8348 #ifdef MOMENT
8349         if (swap) then
8350           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8351         else
8352           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8353         endif
8354 #endif
8355         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8356 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8357       endif
8358 C Cartesian derivatives.
8359       if (lprn) then
8360         write (2,*) 'In eello6_graph2'
8361         do iii=1,2
8362           write (2,*) 'iii=',iii
8363           do kkk=1,5
8364             write (2,*) 'kkk=',kkk
8365             do jjj=1,2
8366               write (2,'(3(2f10.5),5x)')
8367      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8368             enddo
8369           enddo
8370         enddo
8371       endif
8372       do iii=1,2
8373         do kkk=1,5
8374           do lll=1,3
8375 #ifdef MOMENT
8376             if (iii.eq.1) then
8377               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8378             else
8379               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8380             endif
8381 #endif
8382             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8383      &        auxvec(1))
8384             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8385             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8386      &        auxvec(1))
8387             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8388             call transpose2(EUg(1,1,k),auxmat(1,1))
8389             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8390      &        pizda(1,1))
8391             vv(1)=pizda(1,1)-pizda(2,2)
8392             vv(2)=pizda(1,2)+pizda(2,1)
8393             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8394 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8395 #ifdef MOMENT
8396             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8397 #else
8398             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8399 #endif
8400             if (swap) then
8401               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8402             else
8403               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8404             endif
8405           enddo
8406         enddo
8407       enddo
8408       return
8409       end
8410 c----------------------------------------------------------------------------
8411       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8412       implicit real*8 (a-h,o-z)
8413       include 'DIMENSIONS'
8414       include 'COMMON.IOUNITS'
8415       include 'COMMON.CHAIN'
8416       include 'COMMON.DERIV'
8417       include 'COMMON.INTERACT'
8418       include 'COMMON.CONTACTS'
8419       include 'COMMON.TORSION'
8420       include 'COMMON.VAR'
8421       include 'COMMON.GEO'
8422       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8423       logical swap
8424 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8425 C                                                                              C
8426 C      Parallel       Antiparallel                                             C
8427 C                                                                              C
8428 C          o             o                                                     C
8429 C         /l\   /   \   /j\                                                    C
8430 C        /   \ /     \ /   \                                                   C
8431 C       /| o |o       o| o |\                                                  C
8432 C       j|/k\|  /      |/k\|l /                                                C
8433 C        /   \ /       /   \ /                                                 C
8434 C       /     o       /     o                                                  C
8435 C       i             i                                                        C
8436 C                                                                              C
8437 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8438 C
8439 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8440 C           energy moment and not to the cluster cumulant.
8441       iti=itortyp(itype(i))
8442       if (j.lt.nres-1) then
8443         itj1=itortyp(itype(j+1))
8444       else
8445         itj1=ntortyp+1
8446       endif
8447       itk=itortyp(itype(k))
8448       itk1=itortyp(itype(k+1))
8449       if (l.lt.nres-1) then
8450         itl1=itortyp(itype(l+1))
8451       else
8452         itl1=ntortyp+1
8453       endif
8454 #ifdef MOMENT
8455       s1=dip(4,jj,i)*dip(4,kk,k)
8456 #endif
8457       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8458       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8459       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8460       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8461       call transpose2(EE(1,1,itk),auxmat(1,1))
8462       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8463       vv(1)=pizda(1,1)+pizda(2,2)
8464       vv(2)=pizda(2,1)-pizda(1,2)
8465       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8466 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8467 cd     & "sum",-(s2+s3+s4)
8468 #ifdef MOMENT
8469       eello6_graph3=-(s1+s2+s3+s4)
8470 #else
8471       eello6_graph3=-(s2+s3+s4)
8472 #endif
8473 c      eello6_graph3=-s4
8474 C Derivatives in gamma(k-1)
8475       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8476       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8477       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8478       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8479 C Derivatives in gamma(l-1)
8480       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8481       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8482       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8483       vv(1)=pizda(1,1)+pizda(2,2)
8484       vv(2)=pizda(2,1)-pizda(1,2)
8485       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8486       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8487 C Cartesian derivatives.
8488       do iii=1,2
8489         do kkk=1,5
8490           do lll=1,3
8491 #ifdef MOMENT
8492             if (iii.eq.1) then
8493               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8494             else
8495               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8496             endif
8497 #endif
8498             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8499      &        auxvec(1))
8500             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8501             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8502      &        auxvec(1))
8503             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8504             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8505      &        pizda(1,1))
8506             vv(1)=pizda(1,1)+pizda(2,2)
8507             vv(2)=pizda(2,1)-pizda(1,2)
8508             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8509 #ifdef MOMENT
8510             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8511 #else
8512             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8513 #endif
8514             if (swap) then
8515               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8516             else
8517               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8518             endif
8519 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8520           enddo
8521         enddo
8522       enddo
8523       return
8524       end
8525 c----------------------------------------------------------------------------
8526       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8527       implicit real*8 (a-h,o-z)
8528       include 'DIMENSIONS'
8529       include 'COMMON.IOUNITS'
8530       include 'COMMON.CHAIN'
8531       include 'COMMON.DERIV'
8532       include 'COMMON.INTERACT'
8533       include 'COMMON.CONTACTS'
8534       include 'COMMON.TORSION'
8535       include 'COMMON.VAR'
8536       include 'COMMON.GEO'
8537       include 'COMMON.FFIELD'
8538       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8539      & auxvec1(2),auxmat1(2,2)
8540       logical swap
8541 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8542 C                                                                              C
8543 C      Parallel       Antiparallel                                             C
8544 C                                                                              C
8545 C          o             o                                                     C
8546 C         /l\   /   \   /j\                                                    C
8547 C        /   \ /     \ /   \                                                   C
8548 C       /| o |o       o| o |\                                                  C
8549 C     \ j|/k\|      \  |/k\|l                                                  C
8550 C      \ /   \       \ /   \                                                   C
8551 C       o     \       o     \                                                  C
8552 C       i             i                                                        C
8553 C                                                                              C
8554 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8555 C
8556 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8557 C           energy moment and not to the cluster cumulant.
8558 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8559       iti=itortyp(itype(i))
8560       itj=itortyp(itype(j))
8561       if (j.lt.nres-1) then
8562         itj1=itortyp(itype(j+1))
8563       else
8564         itj1=ntortyp+1
8565       endif
8566       itk=itortyp(itype(k))
8567       if (k.lt.nres-1) then
8568         itk1=itortyp(itype(k+1))
8569       else
8570         itk1=ntortyp+1
8571       endif
8572       itl=itortyp(itype(l))
8573       if (l.lt.nres-1) then
8574         itl1=itortyp(itype(l+1))
8575       else
8576         itl1=ntortyp+1
8577       endif
8578 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8579 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8580 cd     & ' itl',itl,' itl1',itl1
8581 #ifdef MOMENT
8582       if (imat.eq.1) then
8583         s1=dip(3,jj,i)*dip(3,kk,k)
8584       else
8585         s1=dip(2,jj,j)*dip(2,kk,l)
8586       endif
8587 #endif
8588       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8589       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8590       if (j.eq.l+1) then
8591         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8592         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8593       else
8594         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8595         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8596       endif
8597       call transpose2(EUg(1,1,k),auxmat(1,1))
8598       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8599       vv(1)=pizda(1,1)-pizda(2,2)
8600       vv(2)=pizda(2,1)+pizda(1,2)
8601       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8602 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8603 #ifdef MOMENT
8604       eello6_graph4=-(s1+s2+s3+s4)
8605 #else
8606       eello6_graph4=-(s2+s3+s4)
8607 #endif
8608 C Derivatives in gamma(i-1)
8609       if (i.gt.1) then
8610 #ifdef MOMENT
8611         if (imat.eq.1) then
8612           s1=dipderg(2,jj,i)*dip(3,kk,k)
8613         else
8614           s1=dipderg(4,jj,j)*dip(2,kk,l)
8615         endif
8616 #endif
8617         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8618         if (j.eq.l+1) then
8619           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8620           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8621         else
8622           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8623           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8624         endif
8625         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8626         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8627 cd          write (2,*) 'turn6 derivatives'
8628 #ifdef MOMENT
8629           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8630 #else
8631           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8632 #endif
8633         else
8634 #ifdef MOMENT
8635           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8636 #else
8637           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8638 #endif
8639         endif
8640       endif
8641 C Derivatives in gamma(k-1)
8642 #ifdef MOMENT
8643       if (imat.eq.1) then
8644         s1=dip(3,jj,i)*dipderg(2,kk,k)
8645       else
8646         s1=dip(2,jj,j)*dipderg(4,kk,l)
8647       endif
8648 #endif
8649       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8650       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8651       if (j.eq.l+1) then
8652         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8653         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8654       else
8655         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8656         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8657       endif
8658       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8659       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8660       vv(1)=pizda(1,1)-pizda(2,2)
8661       vv(2)=pizda(2,1)+pizda(1,2)
8662       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8663       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8664 #ifdef MOMENT
8665         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8666 #else
8667         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8668 #endif
8669       else
8670 #ifdef MOMENT
8671         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8672 #else
8673         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8674 #endif
8675       endif
8676 C Derivatives in gamma(j-1) or gamma(l-1)
8677       if (l.eq.j+1 .and. l.gt.1) then
8678         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8679         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8680         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8681         vv(1)=pizda(1,1)-pizda(2,2)
8682         vv(2)=pizda(2,1)+pizda(1,2)
8683         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8684         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8685       else if (j.gt.1) then
8686         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8687         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8688         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8689         vv(1)=pizda(1,1)-pizda(2,2)
8690         vv(2)=pizda(2,1)+pizda(1,2)
8691         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8692         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8693           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8694         else
8695           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8696         endif
8697       endif
8698 C Cartesian derivatives.
8699       do iii=1,2
8700         do kkk=1,5
8701           do lll=1,3
8702 #ifdef MOMENT
8703             if (iii.eq.1) then
8704               if (imat.eq.1) then
8705                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8706               else
8707                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8708               endif
8709             else
8710               if (imat.eq.1) then
8711                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8712               else
8713                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8714               endif
8715             endif
8716 #endif
8717             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8718      &        auxvec(1))
8719             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8720             if (j.eq.l+1) then
8721               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8722      &          b1(1,j+1),auxvec(1))
8723               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8724             else
8725               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8726      &          b1(1,l+1),auxvec(1))
8727               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8728             endif
8729             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8730      &        pizda(1,1))
8731             vv(1)=pizda(1,1)-pizda(2,2)
8732             vv(2)=pizda(2,1)+pizda(1,2)
8733             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8734             if (swap) then
8735               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8736 #ifdef MOMENT
8737                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8738      &             -(s1+s2+s4)
8739 #else
8740                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8741      &             -(s2+s4)
8742 #endif
8743                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8744               else
8745 #ifdef MOMENT
8746                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8747 #else
8748                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8749 #endif
8750                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8751               endif
8752             else
8753 #ifdef MOMENT
8754               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8755 #else
8756               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8757 #endif
8758               if (l.eq.j+1) then
8759                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8760               else
8761                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8762               endif
8763             endif
8764           enddo
8765         enddo
8766       enddo
8767       return
8768       end
8769 c----------------------------------------------------------------------------
8770       double precision function eello_turn6(i,jj,kk)
8771       implicit real*8 (a-h,o-z)
8772       include 'DIMENSIONS'
8773       include 'COMMON.IOUNITS'
8774       include 'COMMON.CHAIN'
8775       include 'COMMON.DERIV'
8776       include 'COMMON.INTERACT'
8777       include 'COMMON.CONTACTS'
8778       include 'COMMON.TORSION'
8779       include 'COMMON.VAR'
8780       include 'COMMON.GEO'
8781       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8782      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8783      &  ggg1(3),ggg2(3)
8784       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8785      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8786 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8787 C           the respective energy moment and not to the cluster cumulant.
8788       s1=0.0d0
8789       s8=0.0d0
8790       s13=0.0d0
8791 c
8792       eello_turn6=0.0d0
8793       j=i+4
8794       k=i+1
8795       l=i+3
8796       iti=itortyp(itype(i))
8797       itk=itortyp(itype(k))
8798       itk1=itortyp(itype(k+1))
8799       itl=itortyp(itype(l))
8800       itj=itortyp(itype(j))
8801 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8802 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8803 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8804 cd        eello6=0.0d0
8805 cd        return
8806 cd      endif
8807 cd      write (iout,*)
8808 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8809 cd     &   ' and',k,l
8810 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8811       do iii=1,2
8812         do kkk=1,5
8813           do lll=1,3
8814             derx_turn(lll,kkk,iii)=0.0d0
8815           enddo
8816         enddo
8817       enddo
8818 cd      eij=1.0d0
8819 cd      ekl=1.0d0
8820 cd      ekont=1.0d0
8821       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8822 cd      eello6_5=0.0d0
8823 cd      write (2,*) 'eello6_5',eello6_5
8824 #ifdef MOMENT
8825       call transpose2(AEA(1,1,1),auxmat(1,1))
8826       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8827       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8828       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8829 #endif
8830       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8831       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8832       s2 = scalar2(b1(1,k),vtemp1(1))
8833 #ifdef MOMENT
8834       call transpose2(AEA(1,1,2),atemp(1,1))
8835       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8836       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8837       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8838 #endif
8839       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8840       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8841       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8842 #ifdef MOMENT
8843       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8844       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8845       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8846       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8847       ss13 = scalar2(b1(1,k),vtemp4(1))
8848       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8849 #endif
8850 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8851 c      s1=0.0d0
8852 c      s2=0.0d0
8853 c      s8=0.0d0
8854 c      s12=0.0d0
8855 c      s13=0.0d0
8856       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8857 C Derivatives in gamma(i+2)
8858       s1d =0.0d0
8859       s8d =0.0d0
8860 #ifdef MOMENT
8861       call transpose2(AEA(1,1,1),auxmatd(1,1))
8862       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8863       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8864       call transpose2(AEAderg(1,1,2),atempd(1,1))
8865       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8866       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8867 #endif
8868       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8869       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8870       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8871 c      s1d=0.0d0
8872 c      s2d=0.0d0
8873 c      s8d=0.0d0
8874 c      s12d=0.0d0
8875 c      s13d=0.0d0
8876       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8877 C Derivatives in gamma(i+3)
8878 #ifdef MOMENT
8879       call transpose2(AEA(1,1,1),auxmatd(1,1))
8880       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8881       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8882       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8883 #endif
8884       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8885       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8886       s2d = scalar2(b1(1,k),vtemp1d(1))
8887 #ifdef MOMENT
8888       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8889       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8890 #endif
8891       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8892 #ifdef MOMENT
8893       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8894       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8895       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8896 #endif
8897 c      s1d=0.0d0
8898 c      s2d=0.0d0
8899 c      s8d=0.0d0
8900 c      s12d=0.0d0
8901 c      s13d=0.0d0
8902 #ifdef MOMENT
8903       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8904      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8905 #else
8906       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8907      &               -0.5d0*ekont*(s2d+s12d)
8908 #endif
8909 C Derivatives in gamma(i+4)
8910       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8911       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8912       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8913 #ifdef MOMENT
8914       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8915       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8916       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8917 #endif
8918 c      s1d=0.0d0
8919 c      s2d=0.0d0
8920 c      s8d=0.0d0
8921 C      s12d=0.0d0
8922 c      s13d=0.0d0
8923 #ifdef MOMENT
8924       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8925 #else
8926       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8927 #endif
8928 C Derivatives in gamma(i+5)
8929 #ifdef MOMENT
8930       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8931       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8932       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8933 #endif
8934       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8935       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8936       s2d = scalar2(b1(1,k),vtemp1d(1))
8937 #ifdef MOMENT
8938       call transpose2(AEA(1,1,2),atempd(1,1))
8939       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8940       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8941 #endif
8942       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8943       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8944 #ifdef MOMENT
8945       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8946       ss13d = scalar2(b1(1,k),vtemp4d(1))
8947       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8948 #endif
8949 c      s1d=0.0d0
8950 c      s2d=0.0d0
8951 c      s8d=0.0d0
8952 c      s12d=0.0d0
8953 c      s13d=0.0d0
8954 #ifdef MOMENT
8955       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8956      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8957 #else
8958       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8959      &               -0.5d0*ekont*(s2d+s12d)
8960 #endif
8961 C Cartesian derivatives
8962       do iii=1,2
8963         do kkk=1,5
8964           do lll=1,3
8965 #ifdef MOMENT
8966             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8967             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8968             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8969 #endif
8970             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8971             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8972      &          vtemp1d(1))
8973             s2d = scalar2(b1(1,k),vtemp1d(1))
8974 #ifdef MOMENT
8975             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8976             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8977             s8d = -(atempd(1,1)+atempd(2,2))*
8978      &           scalar2(cc(1,1,itl),vtemp2(1))
8979 #endif
8980             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8981      &           auxmatd(1,1))
8982             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8983             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8984 c      s1d=0.0d0
8985 c      s2d=0.0d0
8986 c      s8d=0.0d0
8987 c      s12d=0.0d0
8988 c      s13d=0.0d0
8989 #ifdef MOMENT
8990             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8991      &        - 0.5d0*(s1d+s2d)
8992 #else
8993             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8994      &        - 0.5d0*s2d
8995 #endif
8996 #ifdef MOMENT
8997             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8998      &        - 0.5d0*(s8d+s12d)
8999 #else
9000             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9001      &        - 0.5d0*s12d
9002 #endif
9003           enddo
9004         enddo
9005       enddo
9006 #ifdef MOMENT
9007       do kkk=1,5
9008         do lll=1,3
9009           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9010      &      achuj_tempd(1,1))
9011           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9012           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9013           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9014           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9015           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9016      &      vtemp4d(1))
9017           ss13d = scalar2(b1(1,k),vtemp4d(1))
9018           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9019           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9020         enddo
9021       enddo
9022 #endif
9023 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9024 cd     &  16*eel_turn6_num
9025 cd      goto 1112
9026       if (j.lt.nres-1) then
9027         j1=j+1
9028         j2=j-1
9029       else
9030         j1=j-1
9031         j2=j-2
9032       endif
9033       if (l.lt.nres-1) then
9034         l1=l+1
9035         l2=l-1
9036       else
9037         l1=l-1
9038         l2=l-2
9039       endif
9040       do ll=1,3
9041 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9042 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9043 cgrad        ghalf=0.5d0*ggg1(ll)
9044 cd        ghalf=0.0d0
9045         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9046         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9047         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9048      &    +ekont*derx_turn(ll,2,1)
9049         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9050         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9051      &    +ekont*derx_turn(ll,4,1)
9052         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9053         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9054         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9055 cgrad        ghalf=0.5d0*ggg2(ll)
9056 cd        ghalf=0.0d0
9057         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9058      &    +ekont*derx_turn(ll,2,2)
9059         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9060         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9061      &    +ekont*derx_turn(ll,4,2)
9062         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9063         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9064         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9065       enddo
9066 cd      goto 1112
9067 cgrad      do m=i+1,j-1
9068 cgrad        do ll=1,3
9069 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9070 cgrad        enddo
9071 cgrad      enddo
9072 cgrad      do m=k+1,l-1
9073 cgrad        do ll=1,3
9074 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9075 cgrad        enddo
9076 cgrad      enddo
9077 cgrad1112  continue
9078 cgrad      do m=i+2,j2
9079 cgrad        do ll=1,3
9080 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9081 cgrad        enddo
9082 cgrad      enddo
9083 cgrad      do m=k+2,l2
9084 cgrad        do ll=1,3
9085 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9086 cgrad        enddo
9087 cgrad      enddo
9088 cd      do iii=1,nres-3
9089 cd        write (2,*) iii,g_corr6_loc(iii)
9090 cd      enddo
9091       eello_turn6=ekont*eel_turn6
9092 cd      write (2,*) 'ekont',ekont
9093 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9094       return
9095       end
9096
9097 C-----------------------------------------------------------------------------
9098       double precision function scalar(u,v)
9099 !DIR$ INLINEALWAYS scalar
9100 #ifndef OSF
9101 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9102 #endif
9103       implicit none
9104       double precision u(3),v(3)
9105 cd      double precision sc
9106 cd      integer i
9107 cd      sc=0.0d0
9108 cd      do i=1,3
9109 cd        sc=sc+u(i)*v(i)
9110 cd      enddo
9111 cd      scalar=sc
9112
9113       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9114       return
9115       end
9116 crc-------------------------------------------------
9117       SUBROUTINE MATVEC2(A1,V1,V2)
9118 !DIR$ INLINEALWAYS MATVEC2
9119 #ifndef OSF
9120 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9121 #endif
9122       implicit real*8 (a-h,o-z)
9123       include 'DIMENSIONS'
9124       DIMENSION A1(2,2),V1(2),V2(2)
9125 c      DO 1 I=1,2
9126 c        VI=0.0
9127 c        DO 3 K=1,2
9128 c    3     VI=VI+A1(I,K)*V1(K)
9129 c        Vaux(I)=VI
9130 c    1 CONTINUE
9131
9132       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9133       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9134
9135       v2(1)=vaux1
9136       v2(2)=vaux2
9137       END
9138 C---------------------------------------
9139       SUBROUTINE MATMAT2(A1,A2,A3)
9140 #ifndef OSF
9141 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9142 #endif
9143       implicit real*8 (a-h,o-z)
9144       include 'DIMENSIONS'
9145       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9146 c      DIMENSION AI3(2,2)
9147 c        DO  J=1,2
9148 c          A3IJ=0.0
9149 c          DO K=1,2
9150 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9151 c          enddo
9152 c          A3(I,J)=A3IJ
9153 c       enddo
9154 c      enddo
9155
9156       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9157       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9158       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9159       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9160
9161       A3(1,1)=AI3_11
9162       A3(2,1)=AI3_21
9163       A3(1,2)=AI3_12
9164       A3(2,2)=AI3_22
9165       END
9166
9167 c-------------------------------------------------------------------------
9168       double precision function scalar2(u,v)
9169 !DIR$ INLINEALWAYS scalar2
9170       implicit none
9171       double precision u(2),v(2)
9172       double precision sc
9173       integer i
9174       scalar2=u(1)*v(1)+u(2)*v(2)
9175       return
9176       end
9177
9178 C-----------------------------------------------------------------------------
9179
9180       subroutine transpose2(a,at)
9181 !DIR$ INLINEALWAYS transpose2
9182 #ifndef OSF
9183 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9184 #endif
9185       implicit none
9186       double precision a(2,2),at(2,2)
9187       at(1,1)=a(1,1)
9188       at(1,2)=a(2,1)
9189       at(2,1)=a(1,2)
9190       at(2,2)=a(2,2)
9191       return
9192       end
9193 c--------------------------------------------------------------------------
9194       subroutine transpose(n,a,at)
9195       implicit none
9196       integer n,i,j
9197       double precision a(n,n),at(n,n)
9198       do i=1,n
9199         do j=1,n
9200           at(j,i)=a(i,j)
9201         enddo
9202       enddo
9203       return
9204       end
9205 C---------------------------------------------------------------------------
9206       subroutine prodmat3(a1,a2,kk,transp,prod)
9207 !DIR$ INLINEALWAYS prodmat3
9208 #ifndef OSF
9209 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9210 #endif
9211       implicit none
9212       integer i,j
9213       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9214       logical transp
9215 crc      double precision auxmat(2,2),prod_(2,2)
9216
9217       if (transp) then
9218 crc        call transpose2(kk(1,1),auxmat(1,1))
9219 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9220 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9221
9222            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9223      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9224            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9225      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9226            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9227      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9228            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9229      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9230
9231       else
9232 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9233 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9234
9235            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9236      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9237            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9238      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9239            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9240      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9241            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9242      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9243
9244       endif
9245 c      call transpose2(a2(1,1),a2t(1,1))
9246
9247 crc      print *,transp
9248 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9249 crc      print *,((prod(i,j),i=1,2),j=1,2)
9250
9251       return
9252       end
9253