source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       evdw=0.0D0
1417 ccccc      energy_dec=.false.
1418 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       lprn=.false.
1421 c     if (icall.eq.0) lprn=.false.
1422       ind=0
1423       do i=iatsc_s,iatsc_e
1424         itypi=iabs(itype(i))
1425         if (itypi.eq.ntyp1) cycle
1426         itypi1=iabs(itype(i+1))
1427         xi=c(1,nres+i)
1428         yi=c(2,nres+i)
1429         zi=c(3,nres+i)
1430         dxi=dc_norm(1,nres+i)
1431         dyi=dc_norm(2,nres+i)
1432         dzi=dc_norm(3,nres+i)
1433 c        dsci_inv=dsc_inv(itypi)
1434         dsci_inv=vbld_inv(i+nres)
1435 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1436 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1437 C
1438 C Calculate SC interaction energy.
1439 C
1440         do iint=1,nint_gr(i)
1441           do j=istart(i,iint),iend(i,iint)
1442             ind=ind+1
1443             itypj=iabs(itype(j))
1444             if (itypj.eq.ntyp1) cycle
1445 c            dscj_inv=dsc_inv(itypj)
1446             dscj_inv=vbld_inv(j+nres)
1447 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1448 c     &       1.0d0/vbld(j+nres)
1449 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1450             sig0ij=sigma(itypi,itypj)
1451             chi1=chi(itypi,itypj)
1452             chi2=chi(itypj,itypi)
1453             chi12=chi1*chi2
1454             chip1=chip(itypi)
1455             chip2=chip(itypj)
1456             chip12=chip1*chip2
1457             alf1=alp(itypi)
1458             alf2=alp(itypj)
1459             alf12=0.5D0*(alf1+alf2)
1460 C For diagnostics only!!!
1461 c           chi1=0.0D0
1462 c           chi2=0.0D0
1463 c           chi12=0.0D0
1464 c           chip1=0.0D0
1465 c           chip2=0.0D0
1466 c           chip12=0.0D0
1467 c           alf1=0.0D0
1468 c           alf2=0.0D0
1469 c           alf12=0.0D0
1470             xj=c(1,nres+j)-xi
1471             yj=c(2,nres+j)-yi
1472             zj=c(3,nres+j)-zi
1473             dxj=dc_norm(1,nres+j)
1474             dyj=dc_norm(2,nres+j)
1475             dzj=dc_norm(3,nres+j)
1476 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1477 c            write (iout,*) "j",j," dc_norm",
1478 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480             rij=dsqrt(rrij)
1481 C Calculate angle-dependent terms of energy and contributions to their
1482 C derivatives.
1483             call sc_angular
1484             sigsq=1.0D0/sigsq
1485             sig=sig0ij*dsqrt(sigsq)
1486             rij_shift=1.0D0/rij-sig+sig0ij
1487 c for diagnostics; uncomment
1488 c            rij_shift=1.2*sig0ij
1489 C I hate to put IF's in the loops, but here don't have another choice!!!!
1490             if (rij_shift.le.0.0D0) then
1491               evdw=1.0D20
1492 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1495               return
1496             endif
1497             sigder=-sig*sigsq
1498 c---------------------------------------------------------------
1499             rij_shift=1.0D0/rij_shift
1500             fac=rij_shift**expon
1501             e1=fac*fac*aa(itypi,itypj)
1502             e2=fac*bb(itypi,itypj)
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1507 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1508             evdwij=evdwij*eps2rt*eps3rt
1509             evdw=evdw+evdwij
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1514      &        restyp(itypi),i,restyp(itypj),j,
1515      &        epsi,sigm,chi1,chi2,chip1,chip2,
1516      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1517      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1518      &        evdwij
1519             endif
1520
1521             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1522      &                        'evdw',i,j,evdwij
1523
1524 C Calculate gradient components.
1525             e1=e1*eps1*eps2rt**2*eps3rt**2
1526             fac=-expon*(e1+evdwij)*rij_shift
1527             sigder=fac*sigder
1528             fac=rij*fac
1529 c            fac=0.0d0
1530 C Calculate the radial part of the gradient
1531             gg(1)=xj*fac
1532             gg(2)=yj*fac
1533             gg(3)=zj*fac
1534 C Calculate angular part of the gradient.
1535             call sc_grad
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c      write (iout,*) "Number of loop steps in EGB:",ind
1540 cccc      energy_dec=.false.
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egbv(evdw)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne-Vorobjev potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       common /srutu/ icall
1561       logical lprn
1562       evdw=0.0D0
1563 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1564       evdw=0.0D0
1565       lprn=.false.
1566 c     if (icall.eq.0) lprn=.true.
1567       ind=0
1568       do i=iatsc_s,iatsc_e
1569         itypi=iabs(itype(i))
1570         if (itypi.eq.ntyp1) cycle
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 C
1581 C Calculate SC interaction energy.
1582 C
1583         do iint=1,nint_gr(i)
1584           do j=istart(i,iint),iend(i,iint)
1585             ind=ind+1
1586             itypj=iabs(itype(j))
1587             if (itypj.eq.ntyp1) cycle
1588 c            dscj_inv=dsc_inv(itypj)
1589             dscj_inv=vbld_inv(j+nres)
1590             sig0ij=sigma(itypi,itypj)
1591             r0ij=r0(itypi,itypj)
1592             chi1=chi(itypi,itypj)
1593             chi2=chi(itypj,itypi)
1594             chi12=chi1*chi2
1595             chip1=chip(itypi)
1596             chip2=chip(itypj)
1597             chip12=chip1*chip2
1598             alf1=alp(itypi)
1599             alf2=alp(itypj)
1600             alf12=0.5D0*(alf1+alf2)
1601 C For diagnostics only!!!
1602 c           chi1=0.0D0
1603 c           chi2=0.0D0
1604 c           chi12=0.0D0
1605 c           chip1=0.0D0
1606 c           chip2=0.0D0
1607 c           chip12=0.0D0
1608 c           alf1=0.0D0
1609 c           alf2=0.0D0
1610 c           alf12=0.0D0
1611             xj=c(1,nres+j)-xi
1612             yj=c(2,nres+j)-yi
1613             zj=c(3,nres+j)-zi
1614             dxj=dc_norm(1,nres+j)
1615             dyj=dc_norm(2,nres+j)
1616             dzj=dc_norm(3,nres+j)
1617             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1618             rij=dsqrt(rrij)
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+r0ij
1625 C I hate to put IF's in the loops, but here don't have another choice!!!!
1626             if (rij_shift.le.0.0D0) then
1627               evdw=1.0D20
1628               return
1629             endif
1630             sigder=-sig*sigsq
1631 c---------------------------------------------------------------
1632             rij_shift=1.0D0/rij_shift
1633             fac=rij_shift**expon
1634             e1=fac*fac*aa(itypi,itypj)
1635             e2=fac*bb(itypi,itypj)
1636             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1637             eps2der=evdwij*eps3rt
1638             eps3der=evdwij*eps2rt
1639             fac_augm=rrij**expon
1640             e_augm=augm(itypi,itypj)*fac_augm
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij+e_augm
1643             if (lprn) then
1644             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1645             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647      &        restyp(itypi),i,restyp(itypj),j,
1648      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1649      &        chi1,chi2,chip1,chip2,
1650      &        eps1,eps2rt**2,eps3rt**2,
1651      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1652      &        evdwij+e_augm
1653             endif
1654 C Calculate gradient components.
1655             e1=e1*eps1*eps2rt**2*eps3rt**2
1656             fac=-expon*(e1+evdwij)*rij_shift
1657             sigder=fac*sigder
1658             fac=rij*fac-2*expon*rrij*e_augm
1659 C Calculate the radial part of the gradient
1660             gg(1)=xj*fac
1661             gg(2)=yj*fac
1662             gg(3)=zj*fac
1663 C Calculate angular part of the gradient.
1664             call sc_grad
1665           enddo      ! j
1666         enddo        ! iint
1667       enddo          ! i
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine sc_angular
1671 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1672 C om12. Called by ebp, egb, and egbv.
1673       implicit none
1674       include 'COMMON.CALC'
1675       include 'COMMON.IOUNITS'
1676       erij(1)=xj*rij
1677       erij(2)=yj*rij
1678       erij(3)=zj*rij
1679       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1680       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1681       om12=dxi*dxj+dyi*dyj+dzi*dzj
1682       chiom12=chi12*om12
1683 C Calculate eps1(om12) and its derivative in om12
1684       faceps1=1.0D0-om12*chiom12
1685       faceps1_inv=1.0D0/faceps1
1686       eps1=dsqrt(faceps1_inv)
1687 C Following variable is eps1*deps1/dom12
1688       eps1_om12=faceps1_inv*chiom12
1689 c diagnostics only
1690 c      faceps1_inv=om12
1691 c      eps1=om12
1692 c      eps1_om12=1.0d0
1693 c      write (iout,*) "om12",om12," eps1",eps1
1694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1695 C and om12.
1696       om1om2=om1*om2
1697       chiom1=chi1*om1
1698       chiom2=chi2*om2
1699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1700       sigsq=1.0D0-facsig*faceps1_inv
1701       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1702       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1703       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1704 c diagnostics only
1705 c      sigsq=1.0d0
1706 c      sigsq_om1=0.0d0
1707 c      sigsq_om2=0.0d0
1708 c      sigsq_om12=0.0d0
1709 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1710 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1711 c     &    " eps1",eps1
1712 C Calculate eps2 and its derivatives in om1, om2, and om12.
1713       chipom1=chip1*om1
1714       chipom2=chip2*om2
1715       chipom12=chip12*om12
1716       facp=1.0D0-om12*chipom12
1717       facp_inv=1.0D0/facp
1718       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1719 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1720 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1721 C Following variable is the square root of eps2
1722       eps2rt=1.0D0-facp1*facp_inv
1723 C Following three variables are the derivatives of the square root of eps
1724 C in om1, om2, and om12.
1725       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1726       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1727       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1728 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1729       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1730 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1731 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1732 c     &  " eps2rt_om12",eps2rt_om12
1733 C Calculate whole angle-dependent part of epsilon and contributions
1734 C to its derivatives
1735       return
1736       end
1737 C----------------------------------------------------------------------------
1738       subroutine sc_grad
1739       implicit real*8 (a-h,o-z)
1740       include 'DIMENSIONS'
1741       include 'COMMON.CHAIN'
1742       include 'COMMON.DERIV'
1743       include 'COMMON.CALC'
1744       include 'COMMON.IOUNITS'
1745       double precision dcosom1(3),dcosom2(3)
1746       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1747       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1748       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1749      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1750 c diagnostics only
1751 c      eom1=0.0d0
1752 c      eom2=0.0d0
1753 c      eom12=evdwij*eps1_om12
1754 c end diagnostics
1755 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1756 c     &  " sigder",sigder
1757 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1758 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1759       do k=1,3
1760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1762       enddo
1763       do k=1,3
1764         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1765       enddo
1766 c      write (iout,*) "gg",(gg(k),k=1,3)
1767       do k=1,3
1768         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1769      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1770      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1771         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1772      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1775 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1776 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1777 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1778       enddo
1779 C
1780 C Calculate the components of the gradient in DC and X
1781 C
1782 cgrad      do k=i,j-1
1783 cgrad        do l=1,3
1784 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1785 cgrad        enddo
1786 cgrad      enddo
1787       do l=1,3
1788         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1789         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1790       enddo
1791       return
1792       end
1793 C-----------------------------------------------------------------------
1794       subroutine e_softsphere(evdw)
1795 C
1796 C This subroutine calculates the interaction energy of nonbonded side chains
1797 C assuming the LJ potential of interaction.
1798 C
1799       implicit real*8 (a-h,o-z)
1800       include 'DIMENSIONS'
1801       parameter (accur=1.0d-10)
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.INTERACT'
1808       include 'COMMON.TORSION'
1809       include 'COMMON.SBRIDGE'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CONTACTS'
1813       dimension gg(3)
1814 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823 C
1824 C Calculate SC interaction energy.
1825 C
1826         do iint=1,nint_gr(i)
1827 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1828 cd   &                  'iend=',iend(i,iint)
1829           do j=istart(i,iint),iend(i,iint)
1830             itypj=iabs(itype(j))
1831             if (itypj.eq.ntyp1) cycle
1832             xj=c(1,nres+j)-xi
1833             yj=c(2,nres+j)-yi
1834             zj=c(3,nres+j)-zi
1835             rij=xj*xj+yj*yj+zj*zj
1836 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1837             r0ij=r0(itypi,itypj)
1838             r0ijsq=r0ij*r0ij
1839 c            print *,i,j,r0ij,dsqrt(rij)
1840             if (rij.lt.r0ijsq) then
1841               evdwij=0.25d0*(rij-r0ijsq)**2
1842               fac=rij-r0ijsq
1843             else
1844               evdwij=0.0d0
1845               fac=0.0d0
1846             endif
1847             evdw=evdw+evdwij
1848 C
1849 C Calculate the components of the gradient in DC and X
1850 C
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854             do k=1,3
1855               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1856               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1857               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1858               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1859             enddo
1860 cgrad            do k=i,j-1
1861 cgrad              do l=1,3
1862 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1863 cgrad              enddo
1864 cgrad            enddo
1865           enddo ! j
1866         enddo ! iint
1867       enddo ! i
1868       return
1869       end
1870 C--------------------------------------------------------------------------
1871       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1872      &              eello_turn4)
1873 C
1874 C Soft-sphere potential of p-p interaction
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       include 'COMMON.CONTROL'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.GEO'
1881       include 'COMMON.VAR'
1882       include 'COMMON.LOCAL'
1883       include 'COMMON.CHAIN'
1884       include 'COMMON.DERIV'
1885       include 'COMMON.INTERACT'
1886       include 'COMMON.CONTACTS'
1887       include 'COMMON.TORSION'
1888       include 'COMMON.VECTORS'
1889       include 'COMMON.FFIELD'
1890       dimension ggg(3)
1891 cd      write(iout,*) 'In EELEC_soft_sphere'
1892       ees=0.0D0
1893       evdw1=0.0D0
1894       eel_loc=0.0d0
1895       eello_turn3=0.0d0
1896       eello_turn4=0.0d0
1897       ind=0
1898       do i=iatel_s,iatel_e
1899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1900         dxi=dc(1,i)
1901         dyi=dc(2,i)
1902         dzi=dc(3,i)
1903         xmedi=c(1,i)+0.5d0*dxi
1904         ymedi=c(2,i)+0.5d0*dyi
1905         zmedi=c(3,i)+0.5d0*dzi
1906         num_conti=0
1907 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1908         do j=ielstart(i),ielend(i)
1909           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1910           ind=ind+1
1911           iteli=itel(i)
1912           itelj=itel(j)
1913           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1914           r0ij=rpp(iteli,itelj)
1915           r0ijsq=r0ij*r0ij
1916           dxj=dc(1,j)
1917           dyj=dc(2,j)
1918           dzj=dc(3,j)
1919           xj=c(1,j)+0.5D0*dxj-xmedi
1920           yj=c(2,j)+0.5D0*dyj-ymedi
1921           zj=c(3,j)+0.5D0*dzj-zmedi
1922           rij=xj*xj+yj*yj+zj*zj
1923           if (rij.lt.r0ijsq) then
1924             evdw1ij=0.25d0*(rij-r0ijsq)**2
1925             fac=rij-r0ijsq
1926           else
1927             evdw1ij=0.0d0
1928             fac=0.0d0
1929           endif
1930           evdw1=evdw1+evdw1ij
1931 C
1932 C Calculate contributions to the Cartesian gradient.
1933 C
1934           ggg(1)=fac*xj
1935           ggg(2)=fac*yj
1936           ggg(3)=fac*zj
1937           do k=1,3
1938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1940           enddo
1941 *
1942 * Loop over residues i+1 thru j-1.
1943 *
1944 cgrad          do k=i+1,j-1
1945 cgrad            do l=1,3
1946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1947 cgrad            enddo
1948 cgrad          enddo
1949         enddo ! j
1950       enddo   ! i
1951 cgrad      do i=nnt,nct-1
1952 cgrad        do k=1,3
1953 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1954 cgrad        enddo
1955 cgrad        do j=i+1,nct-1
1956 cgrad          do k=1,3
1957 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1958 cgrad          enddo
1959 cgrad        enddo
1960 cgrad      enddo
1961       return
1962       end
1963 c------------------------------------------------------------------------------
1964       subroutine vec_and_deriv
1965       implicit real*8 (a-h,o-z)
1966       include 'DIMENSIONS'
1967 #ifdef MPI
1968       include 'mpif.h'
1969 #endif
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.VECTORS'
1976       include 'COMMON.SETUP'
1977       include 'COMMON.TIME1'
1978       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1979 C Compute the local reference systems. For reference system (i), the
1980 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1981 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1982 #ifdef PARVEC
1983       do i=ivec_start,ivec_end
1984 #else
1985       do i=1,nres-1
1986 #endif
1987           if (i.eq.nres-1) then
1988 C Case of the last full residue
1989 C Compute the Z-axis
1990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1991             costh=dcos(pi-theta(nres))
1992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1993             do k=1,3
1994               uz(k,i)=fac*uz(k,i)
1995             enddo
1996 C Compute the derivatives of uz
1997             uzder(1,1,1)= 0.0d0
1998             uzder(2,1,1)=-dc_norm(3,i-1)
1999             uzder(3,1,1)= dc_norm(2,i-1)
2000             uzder(1,2,1)= dc_norm(3,i-1)
2001             uzder(2,2,1)= 0.0d0
2002             uzder(3,2,1)=-dc_norm(1,i-1)
2003             uzder(1,3,1)=-dc_norm(2,i-1)
2004             uzder(2,3,1)= dc_norm(1,i-1)
2005             uzder(3,3,1)= 0.0d0
2006             uzder(1,1,2)= 0.0d0
2007             uzder(2,1,2)= dc_norm(3,i)
2008             uzder(3,1,2)=-dc_norm(2,i)
2009             uzder(1,2,2)=-dc_norm(3,i)
2010             uzder(2,2,2)= 0.0d0
2011             uzder(3,2,2)= dc_norm(1,i)
2012             uzder(1,3,2)= dc_norm(2,i)
2013             uzder(2,3,2)=-dc_norm(1,i)
2014             uzder(3,3,2)= 0.0d0
2015 C Compute the Y-axis
2016             facy=fac
2017             do k=1,3
2018               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2019             enddo
2020 C Compute the derivatives of uy
2021             do j=1,3
2022               do k=1,3
2023                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2024      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2025                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2026               enddo
2027               uyder(j,j,1)=uyder(j,j,1)-costh
2028               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2029             enddo
2030             do j=1,2
2031               do k=1,3
2032                 do l=1,3
2033                   uygrad(l,k,j,i)=uyder(l,k,j)
2034                   uzgrad(l,k,j,i)=uzder(l,k,j)
2035                 enddo
2036               enddo
2037             enddo
2038             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2039             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2040             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2041             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2042           else
2043 C Other residues
2044 C Compute the Z-axis
2045             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2046             costh=dcos(pi-theta(i+2))
2047             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2048             do k=1,3
2049               uz(k,i)=fac*uz(k,i)
2050             enddo
2051 C Compute the derivatives of uz
2052             uzder(1,1,1)= 0.0d0
2053             uzder(2,1,1)=-dc_norm(3,i+1)
2054             uzder(3,1,1)= dc_norm(2,i+1)
2055             uzder(1,2,1)= dc_norm(3,i+1)
2056             uzder(2,2,1)= 0.0d0
2057             uzder(3,2,1)=-dc_norm(1,i+1)
2058             uzder(1,3,1)=-dc_norm(2,i+1)
2059             uzder(2,3,1)= dc_norm(1,i+1)
2060             uzder(3,3,1)= 0.0d0
2061             uzder(1,1,2)= 0.0d0
2062             uzder(2,1,2)= dc_norm(3,i)
2063             uzder(3,1,2)=-dc_norm(2,i)
2064             uzder(1,2,2)=-dc_norm(3,i)
2065             uzder(2,2,2)= 0.0d0
2066             uzder(3,2,2)= dc_norm(1,i)
2067             uzder(1,3,2)= dc_norm(2,i)
2068             uzder(2,3,2)=-dc_norm(1,i)
2069             uzder(3,3,2)= 0.0d0
2070 C Compute the Y-axis
2071             facy=fac
2072             do k=1,3
2073               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2074             enddo
2075 C Compute the derivatives of uy
2076             do j=1,3
2077               do k=1,3
2078                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2079      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2080                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2081               enddo
2082               uyder(j,j,1)=uyder(j,j,1)-costh
2083               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2084             enddo
2085             do j=1,2
2086               do k=1,3
2087                 do l=1,3
2088                   uygrad(l,k,j,i)=uyder(l,k,j)
2089                   uzgrad(l,k,j,i)=uzder(l,k,j)
2090                 enddo
2091               enddo
2092             enddo
2093             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2094             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2095             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2096             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2097           endif
2098       enddo
2099       do i=1,nres-1
2100         vbld_inv_temp(1)=vbld_inv(i+1)
2101         if (i.lt.nres-1) then
2102           vbld_inv_temp(2)=vbld_inv(i+2)
2103           else
2104           vbld_inv_temp(2)=vbld_inv(i)
2105           endif
2106         do j=1,2
2107           do k=1,3
2108             do l=1,3
2109               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2110               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2111             enddo
2112           enddo
2113         enddo
2114       enddo
2115 #if defined(PARVEC) && defined(MPI)
2116       if (nfgtasks1.gt.1) then
2117         time00=MPI_Wtime()
2118 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2119 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2120 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2121         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2122      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2123      &   FG_COMM1,IERR)
2124         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2125      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2126      &   FG_COMM1,IERR)
2127         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2128      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2129      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2130         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2131      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2132      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2133         time_gather=time_gather+MPI_Wtime()-time00
2134       endif
2135 c      if (fg_rank.eq.0) then
2136 c        write (iout,*) "Arrays UY and UZ"
2137 c        do i=1,nres-1
2138 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2139 c     &     (uz(k,i),k=1,3)
2140 c        enddo
2141 c      endif
2142 #endif
2143       return
2144       end
2145 C-----------------------------------------------------------------------------
2146       subroutine check_vecgrad
2147       implicit real*8 (a-h,o-z)
2148       include 'DIMENSIONS'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.GEO'
2151       include 'COMMON.VAR'
2152       include 'COMMON.LOCAL'
2153       include 'COMMON.CHAIN'
2154       include 'COMMON.VECTORS'
2155       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2156       dimension uyt(3,maxres),uzt(3,maxres)
2157       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2158       double precision delta /1.0d-7/
2159       call vec_and_deriv
2160 cd      do i=1,nres
2161 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2162 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2163 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2165 cd     &     (dc_norm(if90,i),if90=1,3)
2166 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2167 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2168 cd          write(iout,'(a)')
2169 cd      enddo
2170       do i=1,nres
2171         do j=1,2
2172           do k=1,3
2173             do l=1,3
2174               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2175               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2176             enddo
2177           enddo
2178         enddo
2179       enddo
2180       call vec_and_deriv
2181       do i=1,nres
2182         do j=1,3
2183           uyt(j,i)=uy(j,i)
2184           uzt(j,i)=uz(j,i)
2185         enddo
2186       enddo
2187       do i=1,nres
2188 cd        write (iout,*) 'i=',i
2189         do k=1,3
2190           erij(k)=dc_norm(k,i)
2191         enddo
2192         do j=1,3
2193           do k=1,3
2194             dc_norm(k,i)=erij(k)
2195           enddo
2196           dc_norm(j,i)=dc_norm(j,i)+delta
2197 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2198 c          do k=1,3
2199 c            dc_norm(k,i)=dc_norm(k,i)/fac
2200 c          enddo
2201 c          write (iout,*) (dc_norm(k,i),k=1,3)
2202 c          write (iout,*) (erij(k),k=1,3)
2203           call vec_and_deriv
2204           do k=1,3
2205             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2206             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2207             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2208             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2209           enddo
2210 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2211 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2212 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2213         enddo
2214         do k=1,3
2215           dc_norm(k,i)=erij(k)
2216         enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2219 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2220 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2221 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2222 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2223 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2224 cd          write (iout,'(a)')
2225 cd        enddo
2226       enddo
2227       return
2228       end
2229 C--------------------------------------------------------------------------
2230       subroutine set_matrices
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233 #ifdef MPI
2234       include "mpif.h"
2235       include "COMMON.SETUP"
2236       integer IERR
2237       integer status(MPI_STATUS_SIZE)
2238 #endif
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.GEO'
2241       include 'COMMON.VAR'
2242       include 'COMMON.LOCAL'
2243       include 'COMMON.CHAIN'
2244       include 'COMMON.DERIV'
2245       include 'COMMON.INTERACT'
2246       include 'COMMON.CONTACTS'
2247       include 'COMMON.TORSION'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.FFIELD'
2250       double precision auxvec(2),auxmat(2,2)
2251 C
2252 C Compute the virtual-bond-torsional-angle dependent quantities needed
2253 C to calculate the el-loc multibody terms of various order.
2254 C
2255 c      write(iout,*) 'nphi=',nphi,nres
2256 #ifdef PARMAT
2257       do i=ivec_start+2,ivec_end+2
2258 #else
2259       do i=3,nres+1
2260 #endif
2261 #ifdef NEWCORR
2262         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2263           iti = itortyp(itype(i-2))
2264         else
2265           iti=ntortyp+1
2266         endif
2267 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2268         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2269           iti1 = itortyp(itype(i-1))
2270         else
2271           iti1=ntortyp+1
2272         endif
2273 c        write(iout,*),i
2274         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2275      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2276      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2277         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2278      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2279      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2280 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2281 c     &*(cos(theta(i)/2.0)
2282         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2283      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2284      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2285 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2286 c     &*(cos(theta(i)/2.0)
2287         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2288      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2289      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2290 c        if (ggb1(1,i).eq.0.0d0) then
2291 c        write(iout,*) 'i=',i,ggb1(1,i),
2292 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2293 c     &bnew1(2,1,iti)*cos(theta(i)),
2294 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2295 c        endif
2296         b1(2,i-2)=bnew1(1,2,iti)
2297         gtb1(2,i-2)=0.0
2298         b2(2,i-2)=bnew2(1,2,iti)
2299         gtb2(2,i-2)=0.0
2300         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2301         EE(1,2,i-2)=eeold(1,2,iti)
2302         EE(2,1,i-2)=eeold(2,1,iti)
2303         EE(2,2,i-2)=eeold(2,2,iti)
2304         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2305         gtEE(1,2,i-2)=0.0d0
2306         gtEE(2,2,i-2)=0.0d0
2307         gtEE(2,1,i-2)=0.0d0
2308 c        EE(2,2,iti)=0.0d0
2309 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2310 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2311 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2312 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2313        b1tilde(1,i-2)=b1(1,i-2)
2314        b1tilde(2,i-2)=-b1(2,i-2)
2315        b2tilde(1,i-2)=b2(1,i-2)
2316        b2tilde(2,i-2)=-b2(2,i-2)
2317 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2318 c       write(iout,*)  'b1=',b1(1,i-2)
2319 c       write (iout,*) 'theta=', theta(i-1)
2320        enddo
2321 #ifdef PARMAT
2322       do i=ivec_start+2,ivec_end+2
2323 #else
2324       do i=3,nres+1
2325 #endif
2326 #endif
2327         if (i .lt. nres+1) then
2328           sin1=dsin(phi(i))
2329           cos1=dcos(phi(i))
2330           sintab(i-2)=sin1
2331           costab(i-2)=cos1
2332           obrot(1,i-2)=cos1
2333           obrot(2,i-2)=sin1
2334           sin2=dsin(2*phi(i))
2335           cos2=dcos(2*phi(i))
2336           sintab2(i-2)=sin2
2337           costab2(i-2)=cos2
2338           obrot2(1,i-2)=cos2
2339           obrot2(2,i-2)=sin2
2340           Ug(1,1,i-2)=-cos1
2341           Ug(1,2,i-2)=-sin1
2342           Ug(2,1,i-2)=-sin1
2343           Ug(2,2,i-2)= cos1
2344           Ug2(1,1,i-2)=-cos2
2345           Ug2(1,2,i-2)=-sin2
2346           Ug2(2,1,i-2)=-sin2
2347           Ug2(2,2,i-2)= cos2
2348         else
2349           costab(i-2)=1.0d0
2350           sintab(i-2)=0.0d0
2351           obrot(1,i-2)=1.0d0
2352           obrot(2,i-2)=0.0d0
2353           obrot2(1,i-2)=0.0d0
2354           obrot2(2,i-2)=0.0d0
2355           Ug(1,1,i-2)=1.0d0
2356           Ug(1,2,i-2)=0.0d0
2357           Ug(2,1,i-2)=0.0d0
2358           Ug(2,2,i-2)=1.0d0
2359           Ug2(1,1,i-2)=0.0d0
2360           Ug2(1,2,i-2)=0.0d0
2361           Ug2(2,1,i-2)=0.0d0
2362           Ug2(2,2,i-2)=0.0d0
2363         endif
2364         if (i .gt. 3 .and. i .lt. nres+1) then
2365           obrot_der(1,i-2)=-sin1
2366           obrot_der(2,i-2)= cos1
2367           Ugder(1,1,i-2)= sin1
2368           Ugder(1,2,i-2)=-cos1
2369           Ugder(2,1,i-2)=-cos1
2370           Ugder(2,2,i-2)=-sin1
2371           dwacos2=cos2+cos2
2372           dwasin2=sin2+sin2
2373           obrot2_der(1,i-2)=-dwasin2
2374           obrot2_der(2,i-2)= dwacos2
2375           Ug2der(1,1,i-2)= dwasin2
2376           Ug2der(1,2,i-2)=-dwacos2
2377           Ug2der(2,1,i-2)=-dwacos2
2378           Ug2der(2,2,i-2)=-dwasin2
2379         else
2380           obrot_der(1,i-2)=0.0d0
2381           obrot_der(2,i-2)=0.0d0
2382           Ugder(1,1,i-2)=0.0d0
2383           Ugder(1,2,i-2)=0.0d0
2384           Ugder(2,1,i-2)=0.0d0
2385           Ugder(2,2,i-2)=0.0d0
2386           obrot2_der(1,i-2)=0.0d0
2387           obrot2_der(2,i-2)=0.0d0
2388           Ug2der(1,1,i-2)=0.0d0
2389           Ug2der(1,2,i-2)=0.0d0
2390           Ug2der(2,1,i-2)=0.0d0
2391           Ug2der(2,2,i-2)=0.0d0
2392         endif
2393 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2394         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2395           iti = itortyp(itype(i-2))
2396         else
2397           iti=ntortyp+1
2398         endif
2399 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2400         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2401           iti1 = itortyp(itype(i-1))
2402         else
2403           iti1=ntortyp+1
2404         endif
2405 cd        write (iout,*) '*******i',i,' iti1',iti
2406 cd        write (iout,*) 'b1',b1(:,iti)
2407 cd        write (iout,*) 'b2',b2(:,iti)
2408 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2409 c        if (i .gt. iatel_s+2) then
2410         if (i .gt. nnt+2) then
2411           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2412 #ifdef NEWCORR
2413           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2414 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2415 #endif
2416 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2417 c     &    EE(1,2,iti),EE(2,2,iti)
2418           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2419           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2420 c          write(iout,*) "Macierz EUG",
2421 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2422 c     &    eug(2,2,i-2)
2423           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2424      &    then
2425           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2426           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2427           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2428           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2429           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2430           endif
2431         else
2432           do k=1,2
2433             Ub2(k,i-2)=0.0d0
2434             Ctobr(k,i-2)=0.0d0
2435             Dtobr2(k,i-2)=0.0d0
2436             do l=1,2
2437               EUg(l,k,i-2)=0.0d0
2438               CUg(l,k,i-2)=0.0d0
2439               DUg(l,k,i-2)=0.0d0
2440               DtUg2(l,k,i-2)=0.0d0
2441             enddo
2442           enddo
2443         endif
2444         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2445         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2446         do k=1,2
2447           muder(k,i-2)=Ub2der(k,i-2)
2448         enddo
2449 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2450         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2451           if (itype(i-1).le.ntyp) then
2452             iti1 = itortyp(itype(i-1))
2453           else
2454             iti1=ntortyp+1
2455           endif
2456         else
2457           iti1=ntortyp+1
2458         endif
2459         do k=1,2
2460           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2461         enddo
2462 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2463 cd        write (iout,*) 'mu1',mu1(:,i-2)
2464 cd        write (iout,*) 'mu2',mu2(:,i-2)
2465         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2466      &  then
2467         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2468         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2469         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2470         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2471         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2472 C Vectors and matrices dependent on a single virtual-bond dihedral.
2473         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2474         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2475         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2476         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2477         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2478         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2479         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2480         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2481         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2482         endif
2483       enddo
2484 C Matrices dependent on two consecutive virtual-bond dihedrals.
2485 C The order of matrices is from left to right.
2486       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2487      &then
2488 c      do i=max0(ivec_start,2),ivec_end
2489       do i=2,nres-1
2490         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2491         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2492         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2493         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2494         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2495         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2496         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2497         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2498       enddo
2499       endif
2500 #if defined(MPI) && defined(PARMAT)
2501 #ifdef DEBUG
2502 c      if (fg_rank.eq.0) then
2503         write (iout,*) "Arrays UG and UGDER before GATHER"
2504         do i=1,nres-1
2505           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2506      &     ((ug(l,k,i),l=1,2),k=1,2),
2507      &     ((ugder(l,k,i),l=1,2),k=1,2)
2508         enddo
2509         write (iout,*) "Arrays UG2 and UG2DER"
2510         do i=1,nres-1
2511           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2512      &     ((ug2(l,k,i),l=1,2),k=1,2),
2513      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2514         enddo
2515         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2516         do i=1,nres-1
2517           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2518      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2519      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2520         enddo
2521         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2522         do i=1,nres-1
2523           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2524      &     costab(i),sintab(i),costab2(i),sintab2(i)
2525         enddo
2526         write (iout,*) "Array MUDER"
2527         do i=1,nres-1
2528           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2529         enddo
2530 c      endif
2531 #endif
2532       if (nfgtasks.gt.1) then
2533         time00=MPI_Wtime()
2534 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2535 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2536 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2537 #ifdef MATGATHER
2538         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2548      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2549      &   FG_COMM1,IERR)
2550         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2552      &   FG_COMM1,IERR)
2553         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2555      &   FG_COMM1,IERR)
2556         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2557      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2558      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2559         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2560      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2561      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2562         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2563      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2564      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2565         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2566      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2567      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2568         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2569      &  then
2570         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2571      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2572      &   FG_COMM1,IERR)
2573         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2574      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2575      &   FG_COMM1,IERR)
2576         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2577      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2578      &   FG_COMM1,IERR)
2579        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2580      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2581      &   FG_COMM1,IERR)
2582         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2583      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2586      &   ivec_count(fg_rank1),
2587      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2593      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2594      &   FG_COMM1,IERR)
2595         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2596      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2597      &   FG_COMM1,IERR)
2598         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2599      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2600      &   FG_COMM1,IERR)
2601         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2602      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2603      &   FG_COMM1,IERR)
2604         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2605      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2606      &   FG_COMM1,IERR)
2607         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2608      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2609      &   FG_COMM1,IERR)
2610         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2611      &   ivec_count(fg_rank1),
2612      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2613      &   FG_COMM1,IERR)
2614         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2615      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2616      &   FG_COMM1,IERR)
2617        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2618      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2619      &   FG_COMM1,IERR)
2620         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2621      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2622      &   FG_COMM1,IERR)
2623        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2624      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2625      &   FG_COMM1,IERR)
2626         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2627      &   ivec_count(fg_rank1),
2628      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2629      &   FG_COMM1,IERR)
2630         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2631      &   ivec_count(fg_rank1),
2632      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2635      &   ivec_count(fg_rank1),
2636      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2637      &   MPI_MAT2,FG_COMM1,IERR)
2638         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2639      &   ivec_count(fg_rank1),
2640      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2641      &   MPI_MAT2,FG_COMM1,IERR)
2642         endif
2643 #else
2644 c Passes matrix info through the ring
2645       isend=fg_rank1
2646       irecv=fg_rank1-1
2647       if (irecv.lt.0) irecv=nfgtasks1-1
2648       iprev=irecv
2649       inext=fg_rank1+1
2650       if (inext.ge.nfgtasks1) inext=0
2651       do i=1,nfgtasks1-1
2652 c        write (iout,*) "isend",isend," irecv",irecv
2653 c        call flush(iout)
2654         lensend=lentyp(isend)
2655         lenrecv=lentyp(irecv)
2656 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2657 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2658 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2659 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2660 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2661 c        write (iout,*) "Gather ROTAT1"
2662 c        call flush(iout)
2663 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2664 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2665 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2666 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2667 c        write (iout,*) "Gather ROTAT2"
2668 c        call flush(iout)
2669         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2670      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2671      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2672      &   iprev,4400+irecv,FG_COMM,status,IERR)
2673 c        write (iout,*) "Gather ROTAT_OLD"
2674 c        call flush(iout)
2675         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2676      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2677      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2678      &   iprev,5500+irecv,FG_COMM,status,IERR)
2679 c        write (iout,*) "Gather PRECOMP11"
2680 c        call flush(iout)
2681         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2682      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2683      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2684      &   iprev,6600+irecv,FG_COMM,status,IERR)
2685 c        write (iout,*) "Gather PRECOMP12"
2686 c        call flush(iout)
2687         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2688      &  then
2689         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2690      &   MPI_ROTAT2(lensend),inext,7700+isend,
2691      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2692      &   iprev,7700+irecv,FG_COMM,status,IERR)
2693 c        write (iout,*) "Gather PRECOMP21"
2694 c        call flush(iout)
2695         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2696      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2697      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2698      &   iprev,8800+irecv,FG_COMM,status,IERR)
2699 c        write (iout,*) "Gather PRECOMP22"
2700 c        call flush(iout)
2701         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2702      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2703      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2704      &   MPI_PRECOMP23(lenrecv),
2705      &   iprev,9900+irecv,FG_COMM,status,IERR)
2706 c        write (iout,*) "Gather PRECOMP23"
2707 c        call flush(iout)
2708         endif
2709         isend=irecv
2710         irecv=irecv-1
2711         if (irecv.lt.0) irecv=nfgtasks1-1
2712       enddo
2713 #endif
2714         time_gather=time_gather+MPI_Wtime()-time00
2715       endif
2716 #ifdef DEBUG
2717 c      if (fg_rank.eq.0) then
2718         write (iout,*) "Arrays UG and UGDER"
2719         do i=1,nres-1
2720           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2721      &     ((ug(l,k,i),l=1,2),k=1,2),
2722      &     ((ugder(l,k,i),l=1,2),k=1,2)
2723         enddo
2724         write (iout,*) "Arrays UG2 and UG2DER"
2725         do i=1,nres-1
2726           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2727      &     ((ug2(l,k,i),l=1,2),k=1,2),
2728      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2729         enddo
2730         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2731         do i=1,nres-1
2732           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2733      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2734      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2735         enddo
2736         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2737         do i=1,nres-1
2738           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2739      &     costab(i),sintab(i),costab2(i),sintab2(i)
2740         enddo
2741         write (iout,*) "Array MUDER"
2742         do i=1,nres-1
2743           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2744         enddo
2745 c      endif
2746 #endif
2747 #endif
2748 cd      do i=1,nres
2749 cd        iti = itortyp(itype(i))
2750 cd        write (iout,*) i
2751 cd        do j=1,2
2752 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2753 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2754 cd        enddo
2755 cd      enddo
2756       return
2757       end
2758 C--------------------------------------------------------------------------
2759       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2760 C
2761 C This subroutine calculates the average interaction energy and its gradient
2762 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2763 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2764 C The potential depends both on the distance of peptide-group centers and on
2765 C the orientation of the CA-CA virtual bonds.
2766 C
2767       implicit real*8 (a-h,o-z)
2768 #ifdef MPI
2769       include 'mpif.h'
2770 #endif
2771       include 'DIMENSIONS'
2772       include 'COMMON.CONTROL'
2773       include 'COMMON.SETUP'
2774       include 'COMMON.IOUNITS'
2775       include 'COMMON.GEO'
2776       include 'COMMON.VAR'
2777       include 'COMMON.LOCAL'
2778       include 'COMMON.CHAIN'
2779       include 'COMMON.DERIV'
2780       include 'COMMON.INTERACT'
2781       include 'COMMON.CONTACTS'
2782       include 'COMMON.TORSION'
2783       include 'COMMON.VECTORS'
2784       include 'COMMON.FFIELD'
2785       include 'COMMON.TIME1'
2786       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2787      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2788       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2789      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2790       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2791      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2792      &    num_conti,j1,j2
2793 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2794 #ifdef MOMENT
2795       double precision scal_el /1.0d0/
2796 #else
2797       double precision scal_el /0.5d0/
2798 #endif
2799 C 12/13/98
2800 C 13-go grudnia roku pamietnego...
2801       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2802      &                   0.0d0,1.0d0,0.0d0,
2803      &                   0.0d0,0.0d0,1.0d0/
2804 cd      write(iout,*) 'In EELEC'
2805 cd      do i=1,nloctyp
2806 cd        write(iout,*) 'Type',i
2807 cd        write(iout,*) 'B1',B1(:,i)
2808 cd        write(iout,*) 'B2',B2(:,i)
2809 cd        write(iout,*) 'CC',CC(:,:,i)
2810 cd        write(iout,*) 'DD',DD(:,:,i)
2811 cd        write(iout,*) 'EE',EE(:,:,i)
2812 cd      enddo
2813 cd      call check_vecgrad
2814 cd      stop
2815       if (icheckgrad.eq.1) then
2816         do i=1,nres-1
2817           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2818           do k=1,3
2819             dc_norm(k,i)=dc(k,i)*fac
2820           enddo
2821 c          write (iout,*) 'i',i,' fac',fac
2822         enddo
2823       endif
2824       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2825      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2826      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2827 c        call vec_and_deriv
2828 #ifdef TIMING
2829         time01=MPI_Wtime()
2830 #endif
2831         call set_matrices
2832 #ifdef TIMING
2833         time_mat=time_mat+MPI_Wtime()-time01
2834 #endif
2835       endif
2836 cd      do i=1,nres-1
2837 cd        write (iout,*) 'i=',i
2838 cd        do k=1,3
2839 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2840 cd        enddo
2841 cd        do k=1,3
2842 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2843 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2844 cd        enddo
2845 cd      enddo
2846       t_eelecij=0.0d0
2847       ees=0.0D0
2848       evdw1=0.0D0
2849       eel_loc=0.0d0
2850       eello_turn3=0.0d0
2851       eello_turn4=0.0d0
2852       ind=0
2853       do i=1,nres
2854         num_cont_hb(i)=0
2855       enddo
2856 cd      print '(a)','Enter EELEC'
2857 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2858       do i=1,nres
2859         gel_loc_loc(i)=0.0d0
2860         gcorr_loc(i)=0.0d0
2861       enddo
2862 c
2863 c
2864 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2865 C
2866 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2867 C
2868       do i=iturn3_start,iturn3_end
2869         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2870      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2871         dxi=dc(1,i)
2872         dyi=dc(2,i)
2873         dzi=dc(3,i)
2874         dx_normi=dc_norm(1,i)
2875         dy_normi=dc_norm(2,i)
2876         dz_normi=dc_norm(3,i)
2877         xmedi=c(1,i)+0.5d0*dxi
2878         ymedi=c(2,i)+0.5d0*dyi
2879         zmedi=c(3,i)+0.5d0*dzi
2880         num_conti=0
2881         call eelecij(i,i+2,ees,evdw1,eel_loc)
2882         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2883         num_cont_hb(i)=num_conti
2884       enddo
2885       do i=iturn4_start,iturn4_end
2886         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2887      &    .or. itype(i+3).eq.ntyp1
2888      &    .or. itype(i+4).eq.ntyp1) cycle
2889         dxi=dc(1,i)
2890         dyi=dc(2,i)
2891         dzi=dc(3,i)
2892         dx_normi=dc_norm(1,i)
2893         dy_normi=dc_norm(2,i)
2894         dz_normi=dc_norm(3,i)
2895         xmedi=c(1,i)+0.5d0*dxi
2896         ymedi=c(2,i)+0.5d0*dyi
2897         zmedi=c(3,i)+0.5d0*dzi
2898         num_conti=num_cont_hb(i)
2899 c        write(iout,*) "JESTEM W PETLI"
2900         call eelecij(i,i+3,ees,evdw1,eel_loc)
2901         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2902      &   call eturn4(i,eello_turn4)
2903         num_cont_hb(i)=num_conti
2904       enddo   ! i
2905 c
2906 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2907 c
2908       do i=iatel_s,iatel_e
2909 c       do i=7,7
2910         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2911         dxi=dc(1,i)
2912         dyi=dc(2,i)
2913         dzi=dc(3,i)
2914         dx_normi=dc_norm(1,i)
2915         dy_normi=dc_norm(2,i)
2916         dz_normi=dc_norm(3,i)
2917         xmedi=c(1,i)+0.5d0*dxi
2918         ymedi=c(2,i)+0.5d0*dyi
2919         zmedi=c(3,i)+0.5d0*dzi
2920 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2921         num_conti=num_cont_hb(i)
2922         do j=ielstart(i),ielend(i)
2923 c         do j=13,13
2924 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2925           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2926           call eelecij(i,j,ees,evdw1,eel_loc)
2927         enddo ! j
2928         num_cont_hb(i)=num_conti
2929       enddo   ! i
2930 c      write (iout,*) "Number of loop steps in EELEC:",ind
2931 cd      do i=1,nres
2932 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2933 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2934 cd      enddo
2935 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2936 ccc      eel_loc=eel_loc+eello_turn3
2937 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2938       return
2939       end
2940 C-------------------------------------------------------------------------------
2941       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2942       implicit real*8 (a-h,o-z)
2943       include 'DIMENSIONS'
2944 #ifdef MPI
2945       include "mpif.h"
2946 #endif
2947       include 'COMMON.CONTROL'
2948       include 'COMMON.IOUNITS'
2949       include 'COMMON.GEO'
2950       include 'COMMON.VAR'
2951       include 'COMMON.LOCAL'
2952       include 'COMMON.CHAIN'
2953       include 'COMMON.DERIV'
2954       include 'COMMON.INTERACT'
2955       include 'COMMON.CONTACTS'
2956       include 'COMMON.TORSION'
2957       include 'COMMON.VECTORS'
2958       include 'COMMON.FFIELD'
2959       include 'COMMON.TIME1'
2960       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2961      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2962       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2963      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2964      &    gmuij2(4),gmuji2(4)
2965       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2966      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2967      &    num_conti,j1,j2
2968 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2969 #ifdef MOMENT
2970       double precision scal_el /1.0d0/
2971 #else
2972       double precision scal_el /0.5d0/
2973 #endif
2974 C 12/13/98
2975 C 13-go grudnia roku pamietnego...
2976       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2977      &                   0.0d0,1.0d0,0.0d0,
2978      &                   0.0d0,0.0d0,1.0d0/
2979 c          time00=MPI_Wtime()
2980 cd      write (iout,*) "eelecij",i,j
2981 c          ind=ind+1
2982           iteli=itel(i)
2983           itelj=itel(j)
2984           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2985           aaa=app(iteli,itelj)
2986           bbb=bpp(iteli,itelj)
2987           ael6i=ael6(iteli,itelj)
2988           ael3i=ael3(iteli,itelj)
2989           dxj=dc(1,j)
2990           dyj=dc(2,j)
2991           dzj=dc(3,j)
2992           dx_normj=dc_norm(1,j)
2993           dy_normj=dc_norm(2,j)
2994           dz_normj=dc_norm(3,j)
2995           xj=c(1,j)+0.5D0*dxj-xmedi
2996           yj=c(2,j)+0.5D0*dyj-ymedi
2997           zj=c(3,j)+0.5D0*dzj-zmedi
2998           rij=xj*xj+yj*yj+zj*zj
2999           rrmij=1.0D0/rij
3000           rij=dsqrt(rij)
3001           rmij=1.0D0/rij
3002           r3ij=rrmij*rmij
3003           r6ij=r3ij*r3ij
3004           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3005           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3006           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3007           fac=cosa-3.0D0*cosb*cosg
3008           ev1=aaa*r6ij*r6ij
3009 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3010           if (j.eq.i+2) ev1=scal_el*ev1
3011           ev2=bbb*r6ij
3012           fac3=ael6i*r6ij
3013           fac4=ael3i*r3ij
3014           evdwij=ev1+ev2
3015           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3016           el2=fac4*fac
3017           eesij=el1+el2
3018 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3019           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3020           ees=ees+eesij
3021           evdw1=evdw1+evdwij
3022 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3023 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3024 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3025 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3026
3027           if (energy_dec) then
3028               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3029      &'evdw1',i,j,evdwij
3030      &,iteli,itelj,aaa,evdw1
3031               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3032           endif
3033
3034 C
3035 C Calculate contributions to the Cartesian gradient.
3036 C
3037 #ifdef SPLITELE
3038           facvdw=-6*rrmij*(ev1+evdwij)
3039           facel=-3*rrmij*(el1+eesij)
3040           fac1=fac
3041           erij(1)=xj*rmij
3042           erij(2)=yj*rmij
3043           erij(3)=zj*rmij
3044 *
3045 * Radial derivatives. First process both termini of the fragment (i,j)
3046 *
3047           ggg(1)=facel*xj
3048           ggg(2)=facel*yj
3049           ggg(3)=facel*zj
3050 c          do k=1,3
3051 c            ghalf=0.5D0*ggg(k)
3052 c            gelc(k,i)=gelc(k,i)+ghalf
3053 c            gelc(k,j)=gelc(k,j)+ghalf
3054 c          enddo
3055 c 9/28/08 AL Gradient compotents will be summed only at the end
3056           do k=1,3
3057             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3058             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3059           enddo
3060 *
3061 * Loop over residues i+1 thru j-1.
3062 *
3063 cgrad          do k=i+1,j-1
3064 cgrad            do l=1,3
3065 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3066 cgrad            enddo
3067 cgrad          enddo
3068           ggg(1)=facvdw*xj
3069           ggg(2)=facvdw*yj
3070           ggg(3)=facvdw*zj
3071 c          do k=1,3
3072 c            ghalf=0.5D0*ggg(k)
3073 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3074 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3075 c          enddo
3076 c 9/28/08 AL Gradient compotents will be summed only at the end
3077           do k=1,3
3078             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3079             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3080           enddo
3081 *
3082 * Loop over residues i+1 thru j-1.
3083 *
3084 cgrad          do k=i+1,j-1
3085 cgrad            do l=1,3
3086 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3087 cgrad            enddo
3088 cgrad          enddo
3089 #else
3090           facvdw=ev1+evdwij
3091           facel=el1+eesij
3092           fac1=fac
3093           fac=-3*rrmij*(facvdw+facvdw+facel)
3094           erij(1)=xj*rmij
3095           erij(2)=yj*rmij
3096           erij(3)=zj*rmij
3097 *
3098 * Radial derivatives. First process both termini of the fragment (i,j)
3099 *
3100           ggg(1)=fac*xj
3101           ggg(2)=fac*yj
3102           ggg(3)=fac*zj
3103 c          do k=1,3
3104 c            ghalf=0.5D0*ggg(k)
3105 c            gelc(k,i)=gelc(k,i)+ghalf
3106 c            gelc(k,j)=gelc(k,j)+ghalf
3107 c          enddo
3108 c 9/28/08 AL Gradient compotents will be summed only at the end
3109           do k=1,3
3110             gelc_long(k,j)=gelc(k,j)+ggg(k)
3111             gelc_long(k,i)=gelc(k,i)-ggg(k)
3112           enddo
3113 *
3114 * Loop over residues i+1 thru j-1.
3115 *
3116 cgrad          do k=i+1,j-1
3117 cgrad            do l=1,3
3118 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3119 cgrad            enddo
3120 cgrad          enddo
3121 c 9/28/08 AL Gradient compotents will be summed only at the end
3122           ggg(1)=facvdw*xj
3123           ggg(2)=facvdw*yj
3124           ggg(3)=facvdw*zj
3125           do k=1,3
3126             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3127             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3128           enddo
3129 #endif
3130 *
3131 * Angular part
3132 *
3133           ecosa=2.0D0*fac3*fac1+fac4
3134           fac4=-3.0D0*fac4
3135           fac3=-6.0D0*fac3
3136           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3137           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3138           do k=1,3
3139             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3140             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3141           enddo
3142 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3143 cd   &          (dcosg(k),k=1,3)
3144           do k=1,3
3145             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3146           enddo
3147 c          do k=1,3
3148 c            ghalf=0.5D0*ggg(k)
3149 c            gelc(k,i)=gelc(k,i)+ghalf
3150 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3151 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3152 c            gelc(k,j)=gelc(k,j)+ghalf
3153 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3154 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3155 c          enddo
3156 cgrad          do k=i+1,j-1
3157 cgrad            do l=1,3
3158 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3159 cgrad            enddo
3160 cgrad          enddo
3161           do k=1,3
3162             gelc(k,i)=gelc(k,i)
3163      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3164      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3165             gelc(k,j)=gelc(k,j)
3166      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3167      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3168             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3169             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3170           enddo
3171           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3172      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3173      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3174 C
3175 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3176 C   energy of a peptide unit is assumed in the form of a second-order
3177 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3178 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3179 C   are computed for EVERY pair of non-contiguous peptide groups.
3180 C
3181
3182           if (j.lt.nres-1) then
3183             j1=j+1
3184             j2=j-1
3185           else
3186             j1=j-1
3187             j2=j-2
3188           endif
3189           kkk=0
3190           lll=0
3191           do k=1,2
3192             do l=1,2
3193               kkk=kkk+1
3194               muij(kkk)=mu(k,i)*mu(l,j)
3195 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3196 #ifdef NEWCORR
3197              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3198 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3199              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3200              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3201 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3202              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3203 #endif
3204             enddo
3205           enddo
3206 cd         write (iout,*) 'EELEC: i',i,' j',j
3207 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3208 cd          write(iout,*) 'muij',muij
3209           ury=scalar(uy(1,i),erij)
3210           urz=scalar(uz(1,i),erij)
3211           vry=scalar(uy(1,j),erij)
3212           vrz=scalar(uz(1,j),erij)
3213           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3214           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3215           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3216           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3217           fac=dsqrt(-ael6i)*r3ij
3218           a22=a22*fac
3219           a23=a23*fac
3220           a32=a32*fac
3221           a33=a33*fac
3222 cd          write (iout,'(4i5,4f10.5)')
3223 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3224 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3225 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3226 cd     &      uy(:,j),uz(:,j)
3227 cd          write (iout,'(4f10.5)')
3228 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3229 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3230 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3231 cd           write (iout,'(9f10.5/)')
3232 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3233 C Derivatives of the elements of A in virtual-bond vectors
3234           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3235           do k=1,3
3236             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3237             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3238             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3239             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3240             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3241             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3242             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3243             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3244             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3245             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3246             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3247             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3248           enddo
3249 C Compute radial contributions to the gradient
3250           facr=-3.0d0*rrmij
3251           a22der=a22*facr
3252           a23der=a23*facr
3253           a32der=a32*facr
3254           a33der=a33*facr
3255           agg(1,1)=a22der*xj
3256           agg(2,1)=a22der*yj
3257           agg(3,1)=a22der*zj
3258           agg(1,2)=a23der*xj
3259           agg(2,2)=a23der*yj
3260           agg(3,2)=a23der*zj
3261           agg(1,3)=a32der*xj
3262           agg(2,3)=a32der*yj
3263           agg(3,3)=a32der*zj
3264           agg(1,4)=a33der*xj
3265           agg(2,4)=a33der*yj
3266           agg(3,4)=a33der*zj
3267 C Add the contributions coming from er
3268           fac3=-3.0d0*fac
3269           do k=1,3
3270             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3271             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3272             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3273             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3274           enddo
3275           do k=1,3
3276 C Derivatives in DC(i)
3277 cgrad            ghalf1=0.5d0*agg(k,1)
3278 cgrad            ghalf2=0.5d0*agg(k,2)
3279 cgrad            ghalf3=0.5d0*agg(k,3)
3280 cgrad            ghalf4=0.5d0*agg(k,4)
3281             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3282      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3283             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3284      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3285             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3286      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3287             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3288      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3289 C Derivatives in DC(i+1)
3290             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3291      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3292             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3293      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3294             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3295      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3296             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3297      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3298 C Derivatives in DC(j)
3299             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3300      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3301             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3302      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3303             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3304      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3305             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3306      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3307 C Derivatives in DC(j+1) or DC(nres-1)
3308             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3309      &      -3.0d0*vryg(k,3)*ury)
3310             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3311      &      -3.0d0*vrzg(k,3)*ury)
3312             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3313      &      -3.0d0*vryg(k,3)*urz)
3314             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3315      &      -3.0d0*vrzg(k,3)*urz)
3316 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3317 cgrad              do l=1,4
3318 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3319 cgrad              enddo
3320 cgrad            endif
3321           enddo
3322           acipa(1,1)=a22
3323           acipa(1,2)=a23
3324           acipa(2,1)=a32
3325           acipa(2,2)=a33
3326           a22=-a22
3327           a23=-a23
3328           do l=1,2
3329             do k=1,3
3330               agg(k,l)=-agg(k,l)
3331               aggi(k,l)=-aggi(k,l)
3332               aggi1(k,l)=-aggi1(k,l)
3333               aggj(k,l)=-aggj(k,l)
3334               aggj1(k,l)=-aggj1(k,l)
3335             enddo
3336           enddo
3337           if (j.lt.nres-1) then
3338             a22=-a22
3339             a32=-a32
3340             do l=1,3,2
3341               do k=1,3
3342                 agg(k,l)=-agg(k,l)
3343                 aggi(k,l)=-aggi(k,l)
3344                 aggi1(k,l)=-aggi1(k,l)
3345                 aggj(k,l)=-aggj(k,l)
3346                 aggj1(k,l)=-aggj1(k,l)
3347               enddo
3348             enddo
3349           else
3350             a22=-a22
3351             a23=-a23
3352             a32=-a32
3353             a33=-a33
3354             do l=1,4
3355               do k=1,3
3356                 agg(k,l)=-agg(k,l)
3357                 aggi(k,l)=-aggi(k,l)
3358                 aggi1(k,l)=-aggi1(k,l)
3359                 aggj(k,l)=-aggj(k,l)
3360                 aggj1(k,l)=-aggj1(k,l)
3361               enddo
3362             enddo
3363           endif
3364           ENDIF ! WCORR
3365           IF (wel_loc.gt.0.0d0) THEN
3366 C Contribution to the local-electrostatic energy coming from the i-j pair
3367           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3368      &     +a33*muij(4)
3369 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3370 C Calculate patrial derivative for theta angle
3371 #ifdef NEWCORR
3372          geel_loc_ij=a22*gmuij1(1)
3373      &     +a23*gmuij1(2)
3374      &     +a32*gmuij1(3)
3375      &     +a33*gmuij1(4)
3376 c         write(iout,*) "derivative over thatai"
3377 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3378 c     &   a33*gmuij1(4)
3379          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3380      &      geel_loc_ij*wel_loc
3381 c         write(iout,*) "derivative over thatai-1"
3382 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3383 c     &   a33*gmuij2(4)
3384          geel_loc_ij=
3385      &     a22*gmuij2(1)
3386      &     +a23*gmuij2(2)
3387      &     +a32*gmuij2(3)
3388      &     +a33*gmuij2(4)
3389          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3390      &      geel_loc_ij*wel_loc
3391 c  Derivative over j residue
3392          geel_loc_ji=a22*gmuji1(1)
3393      &     +a23*gmuji1(2)
3394      &     +a32*gmuji1(3)
3395      &     +a33*gmuji1(4)
3396 c         write(iout,*) "derivative over thataj"
3397 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3398 c     &   a33*gmuji1(4)
3399
3400         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3401      &      geel_loc_ji*wel_loc
3402          geel_loc_ji=
3403      &     +a22*gmuji2(1)
3404      &     +a23*gmuji2(2)
3405      &     +a32*gmuji2(3)
3406      &     +a33*gmuji2(4)
3407 c         write(iout,*) "derivative over thataj-1"
3408 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3409 c     &   a33*gmuji2(4)
3410          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3411      &      geel_loc_ji*wel_loc
3412 #endif
3413 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3414
3415           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3416      &            'eelloc',i,j,eel_loc_ij
3417 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3418
3419           eel_loc=eel_loc+eel_loc_ij
3420 C Partial derivatives in virtual-bond dihedral angles gamma
3421           if (i.gt.1)
3422      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3423      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3424      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3425           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3426      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3427      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3428 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3429           do l=1,3
3430             ggg(l)=agg(l,1)*muij(1)+
3431      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3432             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3433             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3434 cgrad            ghalf=0.5d0*ggg(l)
3435 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3436 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3437           enddo
3438 cgrad          do k=i+1,j2
3439 cgrad            do l=1,3
3440 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3441 cgrad            enddo
3442 cgrad          enddo
3443 C Remaining derivatives of eello
3444           do l=1,3
3445             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3446      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3447             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3448      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3449             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3450      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3451             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3452      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3453           enddo
3454           ENDIF
3455 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3456 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3457           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3458      &       .and. num_conti.le.maxconts) then
3459 c            write (iout,*) i,j," entered corr"
3460 C
3461 C Calculate the contact function. The ith column of the array JCONT will
3462 C contain the numbers of atoms that make contacts with the atom I (of numbers
3463 C greater than I). The arrays FACONT and GACONT will contain the values of
3464 C the contact function and its derivative.
3465 c           r0ij=1.02D0*rpp(iteli,itelj)
3466 c           r0ij=1.11D0*rpp(iteli,itelj)
3467             r0ij=2.20D0*rpp(iteli,itelj)
3468 c           r0ij=1.55D0*rpp(iteli,itelj)
3469             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3470             if (fcont.gt.0.0D0) then
3471               num_conti=num_conti+1
3472               if (num_conti.gt.maxconts) then
3473                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3474      &                         ' will skip next contacts for this conf.'
3475               else
3476                 jcont_hb(num_conti,i)=j
3477 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3478 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3479                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3480      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3481 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3482 C  terms.
3483                 d_cont(num_conti,i)=rij
3484 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3485 C     --- Electrostatic-interaction matrix ---
3486                 a_chuj(1,1,num_conti,i)=a22
3487                 a_chuj(1,2,num_conti,i)=a23
3488                 a_chuj(2,1,num_conti,i)=a32
3489                 a_chuj(2,2,num_conti,i)=a33
3490 C     --- Gradient of rij
3491                 do kkk=1,3
3492                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3493                 enddo
3494                 kkll=0
3495                 do k=1,2
3496                   do l=1,2
3497                     kkll=kkll+1
3498                     do m=1,3
3499                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3500                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3501                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3502                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3503                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3504                     enddo
3505                   enddo
3506                 enddo
3507                 ENDIF
3508                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3509 C Calculate contact energies
3510                 cosa4=4.0D0*cosa
3511                 wij=cosa-3.0D0*cosb*cosg
3512                 cosbg1=cosb+cosg
3513                 cosbg2=cosb-cosg
3514 c               fac3=dsqrt(-ael6i)/r0ij**3
3515                 fac3=dsqrt(-ael6i)*r3ij
3516 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3517                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3518                 if (ees0tmp.gt.0) then
3519                   ees0pij=dsqrt(ees0tmp)
3520                 else
3521                   ees0pij=0
3522                 endif
3523 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3524                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3525                 if (ees0tmp.gt.0) then
3526                   ees0mij=dsqrt(ees0tmp)
3527                 else
3528                   ees0mij=0
3529                 endif
3530 c               ees0mij=0.0D0
3531                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3532                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3533 C Diagnostics. Comment out or remove after debugging!
3534 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3535 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3536 c               ees0m(num_conti,i)=0.0D0
3537 C End diagnostics.
3538 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3539 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3540 C Angular derivatives of the contact function
3541                 ees0pij1=fac3/ees0pij
3542                 ees0mij1=fac3/ees0mij
3543                 fac3p=-3.0D0*fac3*rrmij
3544                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3545                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3546 c               ees0mij1=0.0D0
3547                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3548                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3549                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3550                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3551                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3552                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3553                 ecosap=ecosa1+ecosa2
3554                 ecosbp=ecosb1+ecosb2
3555                 ecosgp=ecosg1+ecosg2
3556                 ecosam=ecosa1-ecosa2
3557                 ecosbm=ecosb1-ecosb2
3558                 ecosgm=ecosg1-ecosg2
3559 C Diagnostics
3560 c               ecosap=ecosa1
3561 c               ecosbp=ecosb1
3562 c               ecosgp=ecosg1
3563 c               ecosam=0.0D0
3564 c               ecosbm=0.0D0
3565 c               ecosgm=0.0D0
3566 C End diagnostics
3567                 facont_hb(num_conti,i)=fcont
3568                 fprimcont=fprimcont/rij
3569 cd              facont_hb(num_conti,i)=1.0D0
3570 C Following line is for diagnostics.
3571 cd              fprimcont=0.0D0
3572                 do k=1,3
3573                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3574                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3575                 enddo
3576                 do k=1,3
3577                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3578                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3579                 enddo
3580                 gggp(1)=gggp(1)+ees0pijp*xj
3581                 gggp(2)=gggp(2)+ees0pijp*yj
3582                 gggp(3)=gggp(3)+ees0pijp*zj
3583                 gggm(1)=gggm(1)+ees0mijp*xj
3584                 gggm(2)=gggm(2)+ees0mijp*yj
3585                 gggm(3)=gggm(3)+ees0mijp*zj
3586 C Derivatives due to the contact function
3587                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3588                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3589                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3590                 do k=1,3
3591 c
3592 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3593 c          following the change of gradient-summation algorithm.
3594 c
3595 cgrad                  ghalfp=0.5D0*gggp(k)
3596 cgrad                  ghalfm=0.5D0*gggm(k)
3597                   gacontp_hb1(k,num_conti,i)=!ghalfp
3598      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3599      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3600                   gacontp_hb2(k,num_conti,i)=!ghalfp
3601      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3602      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3603                   gacontp_hb3(k,num_conti,i)=gggp(k)
3604                   gacontm_hb1(k,num_conti,i)=!ghalfm
3605      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3606      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3607                   gacontm_hb2(k,num_conti,i)=!ghalfm
3608      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3609      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3610                   gacontm_hb3(k,num_conti,i)=gggm(k)
3611                 enddo
3612 C Diagnostics. Comment out or remove after debugging!
3613 cdiag           do k=1,3
3614 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3615 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3616 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3617 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3618 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3619 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3620 cdiag           enddo
3621               ENDIF ! wcorr
3622               endif  ! num_conti.le.maxconts
3623             endif  ! fcont.gt.0
3624           endif    ! j.gt.i+1
3625           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3626             do k=1,4
3627               do l=1,3
3628                 ghalf=0.5d0*agg(l,k)
3629                 aggi(l,k)=aggi(l,k)+ghalf
3630                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3631                 aggj(l,k)=aggj(l,k)+ghalf
3632               enddo
3633             enddo
3634             if (j.eq.nres-1 .and. i.lt.j-2) then
3635               do k=1,4
3636                 do l=1,3
3637                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3638                 enddo
3639               enddo
3640             endif
3641           endif
3642 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3643       return
3644       end
3645 C-----------------------------------------------------------------------------
3646       subroutine eturn3(i,eello_turn3)
3647 C Third- and fourth-order contributions from turns
3648       implicit real*8 (a-h,o-z)
3649       include 'DIMENSIONS'
3650       include 'COMMON.IOUNITS'
3651       include 'COMMON.GEO'
3652       include 'COMMON.VAR'
3653       include 'COMMON.LOCAL'
3654       include 'COMMON.CHAIN'
3655       include 'COMMON.DERIV'
3656       include 'COMMON.INTERACT'
3657       include 'COMMON.CONTACTS'
3658       include 'COMMON.TORSION'
3659       include 'COMMON.VECTORS'
3660       include 'COMMON.FFIELD'
3661       include 'COMMON.CONTROL'
3662       dimension ggg(3)
3663       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3664      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3665      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3666      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3667      &  auxgmat2(2,2),auxgmatt2(2,2)
3668       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3669      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3670       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3671      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3672      &    num_conti,j1,j2
3673       j=i+2
3674 c      write (iout,*) "eturn3",i,j,j1,j2
3675       a_temp(1,1)=a22
3676       a_temp(1,2)=a23
3677       a_temp(2,1)=a32
3678       a_temp(2,2)=a33
3679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3680 C
3681 C               Third-order contributions
3682 C
3683 C                 (i+2)o----(i+3)
3684 C                      | |
3685 C                      | |
3686 C                 (i+1)o----i
3687 C
3688 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3689 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3690         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3691 c auxalary matices for theta gradient
3692 c auxalary matrix for i+1 and constant i+2
3693         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3694 c auxalary matrix for i+2 and constant i+1
3695         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3696         call transpose2(auxmat(1,1),auxmat1(1,1))
3697         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3698         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3699         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3700         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3701         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3702         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3703 C Derivatives in theta
3704         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3705      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3706         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3707      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3708
3709         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3710      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3711 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3712 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3713 cd     &    ' eello_turn3_num',4*eello_turn3_num
3714 C Derivatives in gamma(i)
3715         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3716         call transpose2(auxmat2(1,1),auxmat3(1,1))
3717         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3718         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3719 C Derivatives in gamma(i+1)
3720         call matmat2(EUg(1,1,i+1),EUgder(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+1)=gel_loc_turn3(i+1)
3724      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3725 C Cartesian derivatives
3726         do l=1,3
3727 c            ghalf1=0.5d0*agg(l,1)
3728 c            ghalf2=0.5d0*agg(l,2)
3729 c            ghalf3=0.5d0*agg(l,3)
3730 c            ghalf4=0.5d0*agg(l,4)
3731           a_temp(1,1)=aggi(l,1)!+ghalf1
3732           a_temp(1,2)=aggi(l,2)!+ghalf2
3733           a_temp(2,1)=aggi(l,3)!+ghalf3
3734           a_temp(2,2)=aggi(l,4)!+ghalf4
3735           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3736           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3737      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3738           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3739           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3740           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3741           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3742           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3743           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3744      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3745           a_temp(1,1)=aggj(l,1)!+ghalf1
3746           a_temp(1,2)=aggj(l,2)!+ghalf2
3747           a_temp(2,1)=aggj(l,3)!+ghalf3
3748           a_temp(2,2)=aggj(l,4)!+ghalf4
3749           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3750           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3751      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3752           a_temp(1,1)=aggj1(l,1)
3753           a_temp(1,2)=aggj1(l,2)
3754           a_temp(2,1)=aggj1(l,3)
3755           a_temp(2,2)=aggj1(l,4)
3756           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3757           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3758      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3759         enddo
3760       return
3761       end
3762 C-------------------------------------------------------------------------------
3763       subroutine eturn4(i,eello_turn4)
3764 C Third- and fourth-order contributions from turns
3765       implicit real*8 (a-h,o-z)
3766       include 'DIMENSIONS'
3767       include 'COMMON.IOUNITS'
3768       include 'COMMON.GEO'
3769       include 'COMMON.VAR'
3770       include 'COMMON.LOCAL'
3771       include 'COMMON.CHAIN'
3772       include 'COMMON.DERIV'
3773       include 'COMMON.INTERACT'
3774       include 'COMMON.CONTACTS'
3775       include 'COMMON.TORSION'
3776       include 'COMMON.VECTORS'
3777       include 'COMMON.FFIELD'
3778       include 'COMMON.CONTROL'
3779       dimension ggg(3)
3780       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3781      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3782      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3783      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3784      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3785      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3786      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3787       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3788      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3789       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3790      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3791      &    num_conti,j1,j2
3792       j=i+3
3793 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3794 C
3795 C               Fourth-order contributions
3796 C
3797 C                 (i+3)o----(i+4)
3798 C                     /  |
3799 C               (i+2)o   |
3800 C                     \  |
3801 C                 (i+1)o----i
3802 C
3803 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3804 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3805 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3806 c        write(iout,*)"WCHODZE W PROGRAM"
3807         a_temp(1,1)=a22
3808         a_temp(1,2)=a23
3809         a_temp(2,1)=a32
3810         a_temp(2,2)=a33
3811         iti1=itortyp(itype(i+1))
3812         iti2=itortyp(itype(i+2))
3813         iti3=itortyp(itype(i+3))
3814 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3815         call transpose2(EUg(1,1,i+1),e1t(1,1))
3816         call transpose2(Eug(1,1,i+2),e2t(1,1))
3817         call transpose2(Eug(1,1,i+3),e3t(1,1))
3818 C Ematrix derivative in theta
3819         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3820         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3821         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3822         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3823 c       eta1 in derivative theta
3824         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3825         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3826 c       auxgvec is derivative of Ub2 so i+3 theta
3827         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3828 c       auxalary matrix of E i+1
3829         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3830 c        s1=0.0
3831 c        gs1=0.0
3832         s1=scalar2(b1(1,i+2),auxvec(1))
3833 c derivative of theta i+2 with constant i+3
3834         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3835 c derivative of theta i+2 with constant i+2
3836         gs32=scalar2(b1(1,i+2),auxgvec(1))
3837 c derivative of E matix in theta of i+1
3838         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3839
3840         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3841 c       ea31 in derivative theta
3842         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3843         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3844 c auxilary matrix auxgvec of Ub2 with constant E matirx
3845         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3846 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3847         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3848
3849 c        s2=0.0
3850 c        gs2=0.0
3851         s2=scalar2(b1(1,i+1),auxvec(1))
3852 c derivative of theta i+1 with constant i+3
3853         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3854 c derivative of theta i+2 with constant i+1
3855         gs21=scalar2(b1(1,i+1),auxgvec(1))
3856 c derivative of theta i+3 with constant i+1
3857         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3858 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3859 c     &  gtb1(1,i+1)
3860         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3861 c two derivatives over diffetent matrices
3862 c gtae3e2 is derivative over i+3
3863         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3864 c ae3gte2 is derivative over i+2
3865         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3866         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3867 c three possible derivative over theta E matices
3868 c i+1
3869         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3870 c i+2
3871         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3872 c i+3
3873         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3874         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3875
3876         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3877         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3878         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3879
3880         eello_turn4=eello_turn4-(s1+s2+s3)
3881 #ifdef NEWCORR
3882         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3883      &                  -(gs13+gsE13+gsEE1)*wturn4
3884         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3885      &                    -(gs23+gs21+gsEE2)*wturn4
3886         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3887      &                    -(gs32+gsE31+gsEE3)*wturn4
3888 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3889 c     &   gs2
3890 #endif
3891         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3892      &      'eturn4',i,j,-(s1+s2+s3)
3893 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3894 c     &    ' eello_turn4_num',8*eello_turn4_num
3895 C Derivatives in gamma(i)
3896         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3897         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3898         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3899         s1=scalar2(b1(1,i+2),auxvec(1))
3900         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3901         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3902         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3903 C Derivatives in gamma(i+1)
3904         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3905         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3906         s2=scalar2(b1(1,i+1),auxvec(1))
3907         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3908         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3909         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3910         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3911 C Derivatives in gamma(i+2)
3912         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3913         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3914         s1=scalar2(b1(1,i+2),auxvec(1))
3915         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3916         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3917         s2=scalar2(b1(1,i+1),auxvec(1))
3918         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3919         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3920         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3921         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3922 C Cartesian derivatives
3923 C Derivatives of this turn contributions in DC(i+2)
3924         if (j.lt.nres-1) then
3925           do l=1,3
3926             a_temp(1,1)=agg(l,1)
3927             a_temp(1,2)=agg(l,2)
3928             a_temp(2,1)=agg(l,3)
3929             a_temp(2,2)=agg(l,4)
3930             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3931             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3932             s1=scalar2(b1(1,i+2),auxvec(1))
3933             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3934             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3935             s2=scalar2(b1(1,i+1),auxvec(1))
3936             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3937             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3938             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3939             ggg(l)=-(s1+s2+s3)
3940             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3941           enddo
3942         endif
3943 C Remaining derivatives of this turn contribution
3944         do l=1,3
3945           a_temp(1,1)=aggi(l,1)
3946           a_temp(1,2)=aggi(l,2)
3947           a_temp(2,1)=aggi(l,3)
3948           a_temp(2,2)=aggi(l,4)
3949           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3950           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3951           s1=scalar2(b1(1,i+2),auxvec(1))
3952           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3953           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3954           s2=scalar2(b1(1,i+1),auxvec(1))
3955           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3956           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3957           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3958           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3959           a_temp(1,1)=aggi1(l,1)
3960           a_temp(1,2)=aggi1(l,2)
3961           a_temp(2,1)=aggi1(l,3)
3962           a_temp(2,2)=aggi1(l,4)
3963           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3964           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3965           s1=scalar2(b1(1,i+2),auxvec(1))
3966           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3967           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3968           s2=scalar2(b1(1,i+1),auxvec(1))
3969           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3970           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3971           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3972           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3973           a_temp(1,1)=aggj(l,1)
3974           a_temp(1,2)=aggj(l,2)
3975           a_temp(2,1)=aggj(l,3)
3976           a_temp(2,2)=aggj(l,4)
3977           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3978           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3979           s1=scalar2(b1(1,i+2),auxvec(1))
3980           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3981           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3982           s2=scalar2(b1(1,i+1),auxvec(1))
3983           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3984           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3985           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3986           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3987           a_temp(1,1)=aggj1(l,1)
3988           a_temp(1,2)=aggj1(l,2)
3989           a_temp(2,1)=aggj1(l,3)
3990           a_temp(2,2)=aggj1(l,4)
3991           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3992           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3993           s1=scalar2(b1(1,i+2),auxvec(1))
3994           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3995           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3996           s2=scalar2(b1(1,i+1),auxvec(1))
3997           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3998           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3999           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4000 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4001           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4002         enddo
4003       return
4004       end
4005 C-----------------------------------------------------------------------------
4006       subroutine vecpr(u,v,w)
4007       implicit real*8(a-h,o-z)
4008       dimension u(3),v(3),w(3)
4009       w(1)=u(2)*v(3)-u(3)*v(2)
4010       w(2)=-u(1)*v(3)+u(3)*v(1)
4011       w(3)=u(1)*v(2)-u(2)*v(1)
4012       return
4013       end
4014 C-----------------------------------------------------------------------------
4015       subroutine unormderiv(u,ugrad,unorm,ungrad)
4016 C This subroutine computes the derivatives of a normalized vector u, given
4017 C the derivatives computed without normalization conditions, ugrad. Returns
4018 C ungrad.
4019       implicit none
4020       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4021       double precision vec(3)
4022       double precision scalar
4023       integer i,j
4024 c      write (2,*) 'ugrad',ugrad
4025 c      write (2,*) 'u',u
4026       do i=1,3
4027         vec(i)=scalar(ugrad(1,i),u(1))
4028       enddo
4029 c      write (2,*) 'vec',vec
4030       do i=1,3
4031         do j=1,3
4032           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4033         enddo
4034       enddo
4035 c      write (2,*) 'ungrad',ungrad
4036       return
4037       end
4038 C-----------------------------------------------------------------------------
4039       subroutine escp_soft_sphere(evdw2,evdw2_14)
4040 C
4041 C This subroutine calculates the excluded-volume interaction energy between
4042 C peptide-group centers and side chains and its gradient in virtual-bond and
4043 C side-chain vectors.
4044 C
4045       implicit real*8 (a-h,o-z)
4046       include 'DIMENSIONS'
4047       include 'COMMON.GEO'
4048       include 'COMMON.VAR'
4049       include 'COMMON.LOCAL'
4050       include 'COMMON.CHAIN'
4051       include 'COMMON.DERIV'
4052       include 'COMMON.INTERACT'
4053       include 'COMMON.FFIELD'
4054       include 'COMMON.IOUNITS'
4055       include 'COMMON.CONTROL'
4056       dimension ggg(3)
4057       evdw2=0.0D0
4058       evdw2_14=0.0d0
4059       r0_scp=4.5d0
4060 cd    print '(a)','Enter ESCP'
4061 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4062       do i=iatscp_s,iatscp_e
4063         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4064         iteli=itel(i)
4065         xi=0.5D0*(c(1,i)+c(1,i+1))
4066         yi=0.5D0*(c(2,i)+c(2,i+1))
4067         zi=0.5D0*(c(3,i)+c(3,i+1))
4068
4069         do iint=1,nscp_gr(i)
4070
4071         do j=iscpstart(i,iint),iscpend(i,iint)
4072           if (itype(j).eq.ntyp1) cycle
4073           itypj=iabs(itype(j))
4074 C Uncomment following three lines for SC-p interactions
4075 c         xj=c(1,nres+j)-xi
4076 c         yj=c(2,nres+j)-yi
4077 c         zj=c(3,nres+j)-zi
4078 C Uncomment following three lines for Ca-p interactions
4079           xj=c(1,j)-xi
4080           yj=c(2,j)-yi
4081           zj=c(3,j)-zi
4082           rij=xj*xj+yj*yj+zj*zj
4083           r0ij=r0_scp
4084           r0ijsq=r0ij*r0ij
4085           if (rij.lt.r0ijsq) then
4086             evdwij=0.25d0*(rij-r0ijsq)**2
4087             fac=rij-r0ijsq
4088           else
4089             evdwij=0.0d0
4090             fac=0.0d0
4091           endif
4092           evdw2=evdw2+evdwij
4093 C
4094 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4095 C
4096           ggg(1)=xj*fac
4097           ggg(2)=yj*fac
4098           ggg(3)=zj*fac
4099 cgrad          if (j.lt.i) then
4100 cd          write (iout,*) 'j<i'
4101 C Uncomment following three lines for SC-p interactions
4102 c           do k=1,3
4103 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4104 c           enddo
4105 cgrad          else
4106 cd          write (iout,*) 'j>i'
4107 cgrad            do k=1,3
4108 cgrad              ggg(k)=-ggg(k)
4109 C Uncomment following line for SC-p interactions
4110 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4111 cgrad            enddo
4112 cgrad          endif
4113 cgrad          do k=1,3
4114 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4115 cgrad          enddo
4116 cgrad          kstart=min0(i+1,j)
4117 cgrad          kend=max0(i-1,j-1)
4118 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4119 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4120 cgrad          do k=kstart,kend
4121 cgrad            do l=1,3
4122 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4123 cgrad            enddo
4124 cgrad          enddo
4125           do k=1,3
4126             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4127             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4128           enddo
4129         enddo
4130
4131         enddo ! iint
4132       enddo ! i
4133       return
4134       end
4135 C-----------------------------------------------------------------------------
4136       subroutine escp(evdw2,evdw2_14)
4137 C
4138 C This subroutine calculates the excluded-volume interaction energy between
4139 C peptide-group centers and side chains and its gradient in virtual-bond and
4140 C side-chain vectors.
4141 C
4142       implicit real*8 (a-h,o-z)
4143       include 'DIMENSIONS'
4144       include 'COMMON.GEO'
4145       include 'COMMON.VAR'
4146       include 'COMMON.LOCAL'
4147       include 'COMMON.CHAIN'
4148       include 'COMMON.DERIV'
4149       include 'COMMON.INTERACT'
4150       include 'COMMON.FFIELD'
4151       include 'COMMON.IOUNITS'
4152       include 'COMMON.CONTROL'
4153       dimension ggg(3)
4154       evdw2=0.0D0
4155       evdw2_14=0.0d0
4156 cd    print '(a)','Enter ESCP'
4157 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4158       do i=iatscp_s,iatscp_e
4159         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4160         iteli=itel(i)
4161         xi=0.5D0*(c(1,i)+c(1,i+1))
4162         yi=0.5D0*(c(2,i)+c(2,i+1))
4163         zi=0.5D0*(c(3,i)+c(3,i+1))
4164
4165         do iint=1,nscp_gr(i)
4166
4167         do j=iscpstart(i,iint),iscpend(i,iint)
4168           itypj=iabs(itype(j))
4169           if (itypj.eq.ntyp1) cycle
4170 C Uncomment following three lines for SC-p interactions
4171 c         xj=c(1,nres+j)-xi
4172 c         yj=c(2,nres+j)-yi
4173 c         zj=c(3,nres+j)-zi
4174 C Uncomment following three lines for Ca-p interactions
4175           xj=c(1,j)-xi
4176           yj=c(2,j)-yi
4177           zj=c(3,j)-zi
4178           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4179           fac=rrij**expon2
4180           e1=fac*fac*aad(itypj,iteli)
4181           e2=fac*bad(itypj,iteli)
4182           if (iabs(j-i) .le. 2) then
4183             e1=scal14*e1
4184             e2=scal14*e2
4185             evdw2_14=evdw2_14+e1+e2
4186           endif
4187           evdwij=e1+e2
4188           evdw2=evdw2+evdwij
4189           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4190      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4191      &       bad(itypj,iteli)
4192 C
4193 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4194 C
4195           fac=-(evdwij+e1)*rrij
4196           ggg(1)=xj*fac
4197           ggg(2)=yj*fac
4198           ggg(3)=zj*fac
4199 cgrad          if (j.lt.i) then
4200 cd          write (iout,*) 'j<i'
4201 C Uncomment following three lines for SC-p interactions
4202 c           do k=1,3
4203 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4204 c           enddo
4205 cgrad          else
4206 cd          write (iout,*) 'j>i'
4207 cgrad            do k=1,3
4208 cgrad              ggg(k)=-ggg(k)
4209 C Uncomment following line for SC-p interactions
4210 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4211 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4212 cgrad            enddo
4213 cgrad          endif
4214 cgrad          do k=1,3
4215 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4216 cgrad          enddo
4217 cgrad          kstart=min0(i+1,j)
4218 cgrad          kend=max0(i-1,j-1)
4219 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4220 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4221 cgrad          do k=kstart,kend
4222 cgrad            do l=1,3
4223 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4224 cgrad            enddo
4225 cgrad          enddo
4226           do k=1,3
4227             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4228             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4229           enddo
4230         enddo
4231
4232         enddo ! iint
4233       enddo ! i
4234       do i=1,nct
4235         do j=1,3
4236           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4237           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4238           gradx_scp(j,i)=expon*gradx_scp(j,i)
4239         enddo
4240       enddo
4241 C******************************************************************************
4242 C
4243 C                              N O T E !!!
4244 C
4245 C To save time the factor EXPON has been extracted from ALL components
4246 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4247 C use!
4248 C
4249 C******************************************************************************
4250       return
4251       end
4252 C--------------------------------------------------------------------------
4253       subroutine edis(ehpb)
4254 C
4255 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4256 C
4257       implicit real*8 (a-h,o-z)
4258       include 'DIMENSIONS'
4259       include 'COMMON.SBRIDGE'
4260       include 'COMMON.CHAIN'
4261       include 'COMMON.DERIV'
4262       include 'COMMON.VAR'
4263       include 'COMMON.INTERACT'
4264       include 'COMMON.IOUNITS'
4265       dimension ggg(3)
4266       ehpb=0.0D0
4267 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4268 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4269       if (link_end.eq.0) return
4270       do i=link_start,link_end
4271 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4272 C CA-CA distance used in regularization of structure.
4273         ii=ihpb(i)
4274         jj=jhpb(i)
4275 C iii and jjj point to the residues for which the distance is assigned.
4276         if (ii.gt.nres) then
4277           iii=ii-nres
4278           jjj=jj-nres
4279         else
4280           iii=ii
4281           jjj=jj
4282         endif
4283 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4284 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4285 C    distance and angle dependent SS bond potential.
4286         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4287      & iabs(itype(jjj)).eq.1) then
4288           call ssbond_ene(iii,jjj,eij)
4289           ehpb=ehpb+2*eij
4290 cd          write (iout,*) "eij",eij
4291         else
4292 C Calculate the distance between the two points and its difference from the
4293 C target distance.
4294         dd=dist(ii,jj)
4295         rdis=dd-dhpb(i)
4296 C Get the force constant corresponding to this distance.
4297         waga=forcon(i)
4298 C Calculate the contribution to energy.
4299         ehpb=ehpb+waga*rdis*rdis
4300 C
4301 C Evaluate gradient.
4302 C
4303         fac=waga*rdis/dd
4304 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4305 cd   &   ' waga=',waga,' fac=',fac
4306         do j=1,3
4307           ggg(j)=fac*(c(j,jj)-c(j,ii))
4308         enddo
4309 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4310 C If this is a SC-SC distance, we need to calculate the contributions to the
4311 C Cartesian gradient in the SC vectors (ghpbx).
4312         if (iii.lt.ii) then
4313           do j=1,3
4314             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4315             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4316           enddo
4317         endif
4318 cgrad        do j=iii,jjj-1
4319 cgrad          do k=1,3
4320 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4321 cgrad          enddo
4322 cgrad        enddo
4323         do k=1,3
4324           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4325           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4326         enddo
4327         endif
4328       enddo
4329       ehpb=0.5D0*ehpb
4330       return
4331       end
4332 C--------------------------------------------------------------------------
4333       subroutine ssbond_ene(i,j,eij)
4334 C
4335 C Calculate the distance and angle dependent SS-bond potential energy
4336 C using a free-energy function derived based on RHF/6-31G** ab initio
4337 C calculations of diethyl disulfide.
4338 C
4339 C A. Liwo and U. Kozlowska, 11/24/03
4340 C
4341       implicit real*8 (a-h,o-z)
4342       include 'DIMENSIONS'
4343       include 'COMMON.SBRIDGE'
4344       include 'COMMON.CHAIN'
4345       include 'COMMON.DERIV'
4346       include 'COMMON.LOCAL'
4347       include 'COMMON.INTERACT'
4348       include 'COMMON.VAR'
4349       include 'COMMON.IOUNITS'
4350       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4351       itypi=iabs(itype(i))
4352       xi=c(1,nres+i)
4353       yi=c(2,nres+i)
4354       zi=c(3,nres+i)
4355       dxi=dc_norm(1,nres+i)
4356       dyi=dc_norm(2,nres+i)
4357       dzi=dc_norm(3,nres+i)
4358 c      dsci_inv=dsc_inv(itypi)
4359       dsci_inv=vbld_inv(nres+i)
4360       itypj=iabs(itype(j))
4361 c      dscj_inv=dsc_inv(itypj)
4362       dscj_inv=vbld_inv(nres+j)
4363       xj=c(1,nres+j)-xi
4364       yj=c(2,nres+j)-yi
4365       zj=c(3,nres+j)-zi
4366       dxj=dc_norm(1,nres+j)
4367       dyj=dc_norm(2,nres+j)
4368       dzj=dc_norm(3,nres+j)
4369       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4370       rij=dsqrt(rrij)
4371       erij(1)=xj*rij
4372       erij(2)=yj*rij
4373       erij(3)=zj*rij
4374       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4375       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4376       om12=dxi*dxj+dyi*dyj+dzi*dzj
4377       do k=1,3
4378         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4379         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4380       enddo
4381       rij=1.0d0/rij
4382       deltad=rij-d0cm
4383       deltat1=1.0d0-om1
4384       deltat2=1.0d0+om2
4385       deltat12=om2-om1+2.0d0
4386       cosphi=om12-om1*om2
4387       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4388      &  +akct*deltad*deltat12
4389      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4390 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4391 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4392 c     &  " deltat12",deltat12," eij",eij
4393       ed=2*akcm*deltad+akct*deltat12
4394       pom1=akct*deltad
4395       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4396       eom1=-2*akth*deltat1-pom1-om2*pom2
4397       eom2= 2*akth*deltat2+pom1-om1*pom2
4398       eom12=pom2
4399       do k=1,3
4400         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4401         ghpbx(k,i)=ghpbx(k,i)-ggk
4402      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4403      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4404         ghpbx(k,j)=ghpbx(k,j)+ggk
4405      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4406      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4407         ghpbc(k,i)=ghpbc(k,i)-ggk
4408         ghpbc(k,j)=ghpbc(k,j)+ggk
4409       enddo
4410 C
4411 C Calculate the components of the gradient in DC and X
4412 C
4413 cgrad      do k=i,j-1
4414 cgrad        do l=1,3
4415 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4416 cgrad        enddo
4417 cgrad      enddo
4418       return
4419       end
4420 C--------------------------------------------------------------------------
4421       subroutine ebond(estr)
4422 c
4423 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4424 c
4425       implicit real*8 (a-h,o-z)
4426       include 'DIMENSIONS'
4427       include 'COMMON.LOCAL'
4428       include 'COMMON.GEO'
4429       include 'COMMON.INTERACT'
4430       include 'COMMON.DERIV'
4431       include 'COMMON.VAR'
4432       include 'COMMON.CHAIN'
4433       include 'COMMON.IOUNITS'
4434       include 'COMMON.NAMES'
4435       include 'COMMON.FFIELD'
4436       include 'COMMON.CONTROL'
4437       include 'COMMON.SETUP'
4438       double precision u(3),ud(3)
4439       estr=0.0d0
4440       estr1=0.0d0
4441       do i=ibondp_start,ibondp_end
4442         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4443           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4444           do j=1,3
4445           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4446      &      *dc(j,i-1)/vbld(i)
4447           enddo
4448           if (energy_dec) write(iout,*)
4449      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4450         else
4451         diff = vbld(i)-vbldp0
4452         if (energy_dec) write (iout,*)
4453      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4454         estr=estr+diff*diff
4455         do j=1,3
4456           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4457         enddo
4458 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4459         endif
4460       enddo
4461       estr=0.5d0*AKP*estr+estr1
4462 c
4463 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4464 c
4465       do i=ibond_start,ibond_end
4466         iti=iabs(itype(i))
4467         if (iti.ne.10 .and. iti.ne.ntyp1) then
4468           nbi=nbondterm(iti)
4469           if (nbi.eq.1) then
4470             diff=vbld(i+nres)-vbldsc0(1,iti)
4471             if (energy_dec) write (iout,*)
4472      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4473      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4474             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4475             do j=1,3
4476               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4477             enddo
4478           else
4479             do j=1,nbi
4480               diff=vbld(i+nres)-vbldsc0(j,iti)
4481               ud(j)=aksc(j,iti)*diff
4482               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4483             enddo
4484             uprod=u(1)
4485             do j=2,nbi
4486               uprod=uprod*u(j)
4487             enddo
4488             usum=0.0d0
4489             usumsqder=0.0d0
4490             do j=1,nbi
4491               uprod1=1.0d0
4492               uprod2=1.0d0
4493               do k=1,nbi
4494                 if (k.ne.j) then
4495                   uprod1=uprod1*u(k)
4496                   uprod2=uprod2*u(k)*u(k)
4497                 endif
4498               enddo
4499               usum=usum+uprod1
4500               usumsqder=usumsqder+ud(j)*uprod2
4501             enddo
4502             estr=estr+uprod/usum
4503             do j=1,3
4504              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4505             enddo
4506           endif
4507         endif
4508       enddo
4509       return
4510       end
4511 #ifdef CRYST_THETA
4512 C--------------------------------------------------------------------------
4513       subroutine ebend(etheta)
4514 C
4515 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4516 C angles gamma and its derivatives in consecutive thetas and gammas.
4517 C
4518       implicit real*8 (a-h,o-z)
4519       include 'DIMENSIONS'
4520       include 'COMMON.LOCAL'
4521       include 'COMMON.GEO'
4522       include 'COMMON.INTERACT'
4523       include 'COMMON.DERIV'
4524       include 'COMMON.VAR'
4525       include 'COMMON.CHAIN'
4526       include 'COMMON.IOUNITS'
4527       include 'COMMON.NAMES'
4528       include 'COMMON.FFIELD'
4529       include 'COMMON.CONTROL'
4530       common /calcthet/ term1,term2,termm,diffak,ratak,
4531      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4532      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4533       double precision y(2),z(2)
4534       delta=0.02d0*pi
4535 c      time11=dexp(-2*time)
4536 c      time12=1.0d0
4537       etheta=0.0D0
4538 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4539       do i=ithet_start,ithet_end
4540         if (itype(i-1).eq.ntyp1) cycle
4541 C Zero the energy function and its derivative at 0 or pi.
4542         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4543         it=itype(i-1)
4544         ichir1=isign(1,itype(i-2))
4545         ichir2=isign(1,itype(i))
4546          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4547          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4548          if (itype(i-1).eq.10) then
4549           itype1=isign(10,itype(i-2))
4550           ichir11=isign(1,itype(i-2))
4551           ichir12=isign(1,itype(i-2))
4552           itype2=isign(10,itype(i))
4553           ichir21=isign(1,itype(i))
4554           ichir22=isign(1,itype(i))
4555          endif
4556
4557         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4558 #ifdef OSF
4559           phii=phi(i)
4560           if (phii.ne.phii) phii=150.0
4561 #else
4562           phii=phi(i)
4563 #endif
4564           y(1)=dcos(phii)
4565           y(2)=dsin(phii)
4566         else
4567           y(1)=0.0D0
4568           y(2)=0.0D0
4569         endif
4570         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4571 #ifdef OSF
4572           phii1=phi(i+1)
4573           if (phii1.ne.phii1) phii1=150.0
4574           phii1=pinorm(phii1)
4575           z(1)=cos(phii1)
4576 #else
4577           phii1=phi(i+1)
4578           z(1)=dcos(phii1)
4579 #endif
4580           z(2)=dsin(phii1)
4581         else
4582           z(1)=0.0D0
4583           z(2)=0.0D0
4584         endif
4585 C Calculate the "mean" value of theta from the part of the distribution
4586 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4587 C In following comments this theta will be referred to as t_c.
4588         thet_pred_mean=0.0d0
4589         do k=1,2
4590             athetk=athet(k,it,ichir1,ichir2)
4591             bthetk=bthet(k,it,ichir1,ichir2)
4592           if (it.eq.10) then
4593              athetk=athet(k,itype1,ichir11,ichir12)
4594              bthetk=bthet(k,itype2,ichir21,ichir22)
4595           endif
4596          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4597         enddo
4598         dthett=thet_pred_mean*ssd
4599         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4600 C Derivatives of the "mean" values in gamma1 and gamma2.
4601         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4602      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4603          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4604      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4605          if (it.eq.10) then
4606       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4607      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4608         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4609      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4610          endif
4611         if (theta(i).gt.pi-delta) then
4612           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4613      &         E_tc0)
4614           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4615           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4616           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4617      &        E_theta)
4618           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4619      &        E_tc)
4620         else if (theta(i).lt.delta) then
4621           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4622           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4623           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4624      &        E_theta)
4625           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4626           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4627      &        E_tc)
4628         else
4629           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4630      &        E_theta,E_tc)
4631         endif
4632         etheta=etheta+ethetai
4633         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4634      &      'ebend',i,ethetai
4635         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4636         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4637         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4638       enddo
4639 C Ufff.... We've done all this!!!
4640       return
4641       end
4642 C---------------------------------------------------------------------------
4643       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4644      &     E_tc)
4645       implicit real*8 (a-h,o-z)
4646       include 'DIMENSIONS'
4647       include 'COMMON.LOCAL'
4648       include 'COMMON.IOUNITS'
4649       common /calcthet/ term1,term2,termm,diffak,ratak,
4650      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4651      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4652 C Calculate the contributions to both Gaussian lobes.
4653 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4654 C The "polynomial part" of the "standard deviation" of this part of
4655 C the distribution.
4656         sig=polthet(3,it)
4657         do j=2,0,-1
4658           sig=sig*thet_pred_mean+polthet(j,it)
4659         enddo
4660 C Derivative of the "interior part" of the "standard deviation of the"
4661 C gamma-dependent Gaussian lobe in t_c.
4662         sigtc=3*polthet(3,it)
4663         do j=2,1,-1
4664           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4665         enddo
4666         sigtc=sig*sigtc
4667 C Set the parameters of both Gaussian lobes of the distribution.
4668 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4669         fac=sig*sig+sigc0(it)
4670         sigcsq=fac+fac
4671         sigc=1.0D0/sigcsq
4672 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4673         sigsqtc=-4.0D0*sigcsq*sigtc
4674 c       print *,i,sig,sigtc,sigsqtc
4675 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4676         sigtc=-sigtc/(fac*fac)
4677 C Following variable is sigma(t_c)**(-2)
4678         sigcsq=sigcsq*sigcsq
4679         sig0i=sig0(it)
4680         sig0inv=1.0D0/sig0i**2
4681         delthec=thetai-thet_pred_mean
4682         delthe0=thetai-theta0i
4683         term1=-0.5D0*sigcsq*delthec*delthec
4684         term2=-0.5D0*sig0inv*delthe0*delthe0
4685 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4686 C NaNs in taking the logarithm. We extract the largest exponent which is added
4687 C to the energy (this being the log of the distribution) at the end of energy
4688 C term evaluation for this virtual-bond angle.
4689         if (term1.gt.term2) then
4690           termm=term1
4691           term2=dexp(term2-termm)
4692           term1=1.0d0
4693         else
4694           termm=term2
4695           term1=dexp(term1-termm)
4696           term2=1.0d0
4697         endif
4698 C The ratio between the gamma-independent and gamma-dependent lobes of
4699 C the distribution is a Gaussian function of thet_pred_mean too.
4700         diffak=gthet(2,it)-thet_pred_mean
4701         ratak=diffak/gthet(3,it)**2
4702         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4703 C Let's differentiate it in thet_pred_mean NOW.
4704         aktc=ak*ratak
4705 C Now put together the distribution terms to make complete distribution.
4706         termexp=term1+ak*term2
4707         termpre=sigc+ak*sig0i
4708 C Contribution of the bending energy from this theta is just the -log of
4709 C the sum of the contributions from the two lobes and the pre-exponential
4710 C factor. Simple enough, isn't it?
4711         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4712 C NOW the derivatives!!!
4713 C 6/6/97 Take into account the deformation.
4714         E_theta=(delthec*sigcsq*term1
4715      &       +ak*delthe0*sig0inv*term2)/termexp
4716         E_tc=((sigtc+aktc*sig0i)/termpre
4717      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4718      &       aktc*term2)/termexp)
4719       return
4720       end
4721 c-----------------------------------------------------------------------------
4722       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4723       implicit real*8 (a-h,o-z)
4724       include 'DIMENSIONS'
4725       include 'COMMON.LOCAL'
4726       include 'COMMON.IOUNITS'
4727       common /calcthet/ term1,term2,termm,diffak,ratak,
4728      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4729      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4730       delthec=thetai-thet_pred_mean
4731       delthe0=thetai-theta0i
4732 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4733       t3 = thetai-thet_pred_mean
4734       t6 = t3**2
4735       t9 = term1
4736       t12 = t3*sigcsq
4737       t14 = t12+t6*sigsqtc
4738       t16 = 1.0d0
4739       t21 = thetai-theta0i
4740       t23 = t21**2
4741       t26 = term2
4742       t27 = t21*t26
4743       t32 = termexp
4744       t40 = t32**2
4745       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4746      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4747      & *(-t12*t9-ak*sig0inv*t27)
4748       return
4749       end
4750 #else
4751 C--------------------------------------------------------------------------
4752       subroutine ebend(etheta)
4753 C
4754 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4755 C angles gamma and its derivatives in consecutive thetas and gammas.
4756 C ab initio-derived potentials from
4757 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4758 C
4759       implicit real*8 (a-h,o-z)
4760       include 'DIMENSIONS'
4761       include 'COMMON.LOCAL'
4762       include 'COMMON.GEO'
4763       include 'COMMON.INTERACT'
4764       include 'COMMON.DERIV'
4765       include 'COMMON.VAR'
4766       include 'COMMON.CHAIN'
4767       include 'COMMON.IOUNITS'
4768       include 'COMMON.NAMES'
4769       include 'COMMON.FFIELD'
4770       include 'COMMON.CONTROL'
4771       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4772      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4773      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4774      & sinph1ph2(maxdouble,maxdouble)
4775       logical lprn /.false./, lprn1 /.false./
4776       etheta=0.0D0
4777       do i=ithet_start,ithet_end
4778         if (itype(i-1).eq.ntyp1) cycle
4779         if (iabs(itype(i+1)).eq.20) iblock=2
4780         if (iabs(itype(i+1)).ne.20) iblock=1
4781         dethetai=0.0d0
4782         dephii=0.0d0
4783         dephii1=0.0d0
4784         theti2=0.5d0*theta(i)
4785         ityp2=ithetyp((itype(i-1)))
4786         do k=1,nntheterm
4787           coskt(k)=dcos(k*theti2)
4788           sinkt(k)=dsin(k*theti2)
4789         enddo
4790         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4791 #ifdef OSF
4792           phii=phi(i)
4793           if (phii.ne.phii) phii=150.0
4794 #else
4795           phii=phi(i)
4796 #endif
4797           ityp1=ithetyp((itype(i-2)))
4798 C propagation of chirality for glycine type
4799           do k=1,nsingle
4800             cosph1(k)=dcos(k*phii)
4801             sinph1(k)=dsin(k*phii)
4802           enddo
4803         else
4804           phii=0.0d0
4805           ityp1=nthetyp+1
4806           do k=1,nsingle
4807             cosph1(k)=0.0d0
4808             sinph1(k)=0.0d0
4809           enddo
4810         endif
4811         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4812 #ifdef OSF
4813           phii1=phi(i+1)
4814           if (phii1.ne.phii1) phii1=150.0
4815           phii1=pinorm(phii1)
4816 #else
4817           phii1=phi(i+1)
4818 #endif
4819           ityp3=ithetyp((itype(i)))
4820           do k=1,nsingle
4821             cosph2(k)=dcos(k*phii1)
4822             sinph2(k)=dsin(k*phii1)
4823           enddo
4824         else
4825           phii1=0.0d0
4826           ityp3=nthetyp+1
4827           do k=1,nsingle
4828             cosph2(k)=0.0d0
4829             sinph2(k)=0.0d0
4830           enddo
4831         endif
4832         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4833         do k=1,ndouble
4834           do l=1,k-1
4835             ccl=cosph1(l)*cosph2(k-l)
4836             ssl=sinph1(l)*sinph2(k-l)
4837             scl=sinph1(l)*cosph2(k-l)
4838             csl=cosph1(l)*sinph2(k-l)
4839             cosph1ph2(l,k)=ccl-ssl
4840             cosph1ph2(k,l)=ccl+ssl
4841             sinph1ph2(l,k)=scl+csl
4842             sinph1ph2(k,l)=scl-csl
4843           enddo
4844         enddo
4845         if (lprn) then
4846         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4847      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4848         write (iout,*) "coskt and sinkt"
4849         do k=1,nntheterm
4850           write (iout,*) k,coskt(k),sinkt(k)
4851         enddo
4852         endif
4853         do k=1,ntheterm
4854           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4855           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4856      &      *coskt(k)
4857           if (lprn)
4858      &    write (iout,*) "k",k,"
4859      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4860      &     " ethetai",ethetai
4861         enddo
4862         if (lprn) then
4863         write (iout,*) "cosph and sinph"
4864         do k=1,nsingle
4865           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4866         enddo
4867         write (iout,*) "cosph1ph2 and sinph2ph2"
4868         do k=2,ndouble
4869           do l=1,k-1
4870             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4871      &         sinph1ph2(l,k),sinph1ph2(k,l)
4872           enddo
4873         enddo
4874         write(iout,*) "ethetai",ethetai
4875         endif
4876         do m=1,ntheterm2
4877           do k=1,nsingle
4878             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4879      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4880      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4881      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4882             ethetai=ethetai+sinkt(m)*aux
4883             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4884             dephii=dephii+k*sinkt(m)*(
4885      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4886      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4887             dephii1=dephii1+k*sinkt(m)*(
4888      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4889      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4890             if (lprn)
4891      &      write (iout,*) "m",m," k",k," bbthet",
4892      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4893      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4894      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4895      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4896           enddo
4897         enddo
4898         if (lprn)
4899      &  write(iout,*) "ethetai",ethetai
4900         do m=1,ntheterm3
4901           do k=2,ndouble
4902             do l=1,k-1
4903               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4904      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4905      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4906      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4907               ethetai=ethetai+sinkt(m)*aux
4908               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4909               dephii=dephii+l*sinkt(m)*(
4910      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4911      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4912      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4913      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4914               dephii1=dephii1+(k-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               if (lprn) then
4920               write (iout,*) "m",m," k",k," l",l," ffthet",
4921      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4922      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4923      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4924      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4925      &            " ethetai",ethetai
4926               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4927      &            cosph1ph2(k,l)*sinkt(m),
4928      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4929               endif
4930             enddo
4931           enddo
4932         enddo
4933 10      continue
4934 c        lprn1=.true.
4935         if (lprn1)
4936      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4937      &   i,theta(i)*rad2deg,phii*rad2deg,
4938      &   phii1*rad2deg,ethetai
4939 c        lprn1=.false.
4940         etheta=etheta+ethetai
4941         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4942         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4943         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4944       enddo
4945       return
4946       end
4947 #endif
4948 #ifdef CRYST_SC
4949 c-----------------------------------------------------------------------------
4950       subroutine esc(escloc)
4951 C Calculate the local energy of a side chain and its derivatives in the
4952 C corresponding virtual-bond valence angles THETA and the spherical angles
4953 C ALPHA and OMEGA.
4954       implicit real*8 (a-h,o-z)
4955       include 'DIMENSIONS'
4956       include 'COMMON.GEO'
4957       include 'COMMON.LOCAL'
4958       include 'COMMON.VAR'
4959       include 'COMMON.INTERACT'
4960       include 'COMMON.DERIV'
4961       include 'COMMON.CHAIN'
4962       include 'COMMON.IOUNITS'
4963       include 'COMMON.NAMES'
4964       include 'COMMON.FFIELD'
4965       include 'COMMON.CONTROL'
4966       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4967      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4968       common /sccalc/ time11,time12,time112,theti,it,nlobit
4969       delta=0.02d0*pi
4970       escloc=0.0D0
4971 c     write (iout,'(a)') 'ESC'
4972       do i=loc_start,loc_end
4973         it=itype(i)
4974         if (it.eq.ntyp1) cycle
4975         if (it.eq.10) goto 1
4976         nlobit=nlob(iabs(it))
4977 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4978 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4979         theti=theta(i+1)-pipol
4980         x(1)=dtan(theti)
4981         x(2)=alph(i)
4982         x(3)=omeg(i)
4983
4984         if (x(2).gt.pi-delta) then
4985           xtemp(1)=x(1)
4986           xtemp(2)=pi-delta
4987           xtemp(3)=x(3)
4988           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4989           xtemp(2)=pi
4990           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4991           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4992      &        escloci,dersc(2))
4993           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4994      &        ddersc0(1),dersc(1))
4995           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4996      &        ddersc0(3),dersc(3))
4997           xtemp(2)=pi-delta
4998           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4999           xtemp(2)=pi
5000           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5001           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5002      &            dersc0(2),esclocbi,dersc02)
5003           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5004      &            dersc12,dersc01)
5005           call splinthet(x(2),0.5d0*delta,ss,ssd)
5006           dersc0(1)=dersc01
5007           dersc0(2)=dersc02
5008           dersc0(3)=0.0d0
5009           do k=1,3
5010             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5011           enddo
5012           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5013 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5014 c    &             esclocbi,ss,ssd
5015           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5016 c         escloci=esclocbi
5017 c         write (iout,*) escloci
5018         else if (x(2).lt.delta) then
5019           xtemp(1)=x(1)
5020           xtemp(2)=delta
5021           xtemp(3)=x(3)
5022           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5023           xtemp(2)=0.0d0
5024           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5025           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5026      &        escloci,dersc(2))
5027           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5028      &        ddersc0(1),dersc(1))
5029           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5030      &        ddersc0(3),dersc(3))
5031           xtemp(2)=delta
5032           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5033           xtemp(2)=0.0d0
5034           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5035           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5036      &            dersc0(2),esclocbi,dersc02)
5037           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5038      &            dersc12,dersc01)
5039           dersc0(1)=dersc01
5040           dersc0(2)=dersc02
5041           dersc0(3)=0.0d0
5042           call splinthet(x(2),0.5d0*delta,ss,ssd)
5043           do k=1,3
5044             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5045           enddo
5046           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5047 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5048 c    &             esclocbi,ss,ssd
5049           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5050 c         write (iout,*) escloci
5051         else
5052           call enesc(x,escloci,dersc,ddummy,.false.)
5053         endif
5054
5055         escloc=escloc+escloci
5056         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5057      &     'escloc',i,escloci
5058 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5059
5060         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5061      &   wscloc*dersc(1)
5062         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5063         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5064     1   continue
5065       enddo
5066       return
5067       end
5068 C---------------------------------------------------------------------------
5069       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5070       implicit real*8 (a-h,o-z)
5071       include 'DIMENSIONS'
5072       include 'COMMON.GEO'
5073       include 'COMMON.LOCAL'
5074       include 'COMMON.IOUNITS'
5075       common /sccalc/ time11,time12,time112,theti,it,nlobit
5076       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5077       double precision contr(maxlob,-1:1)
5078       logical mixed
5079 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5080         escloc_i=0.0D0
5081         do j=1,3
5082           dersc(j)=0.0D0
5083           if (mixed) ddersc(j)=0.0d0
5084         enddo
5085         x3=x(3)
5086
5087 C Because of periodicity of the dependence of the SC energy in omega we have
5088 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5089 C To avoid underflows, first compute & store the exponents.
5090
5091         do iii=-1,1
5092
5093           x(3)=x3+iii*dwapi
5094
5095           do j=1,nlobit
5096             do k=1,3
5097               z(k)=x(k)-censc(k,j,it)
5098             enddo
5099             do k=1,3
5100               Axk=0.0D0
5101               do l=1,3
5102                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5103               enddo
5104               Ax(k,j,iii)=Axk
5105             enddo
5106             expfac=0.0D0
5107             do k=1,3
5108               expfac=expfac+Ax(k,j,iii)*z(k)
5109             enddo
5110             contr(j,iii)=expfac
5111           enddo ! j
5112
5113         enddo ! iii
5114
5115         x(3)=x3
5116 C As in the case of ebend, we want to avoid underflows in exponentiation and
5117 C subsequent NaNs and INFs in energy calculation.
5118 C Find the largest exponent
5119         emin=contr(1,-1)
5120         do iii=-1,1
5121           do j=1,nlobit
5122             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5123           enddo
5124         enddo
5125         emin=0.5D0*emin
5126 cd      print *,'it=',it,' emin=',emin
5127
5128 C Compute the contribution to SC energy and derivatives
5129         do iii=-1,1
5130
5131           do j=1,nlobit
5132 #ifdef OSF
5133             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5134             if(adexp.ne.adexp) adexp=1.0
5135             expfac=dexp(adexp)
5136 #else
5137             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5138 #endif
5139 cd          print *,'j=',j,' expfac=',expfac
5140             escloc_i=escloc_i+expfac
5141             do k=1,3
5142               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5143             enddo
5144             if (mixed) then
5145               do k=1,3,2
5146                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5147      &            +gaussc(k,2,j,it))*expfac
5148               enddo
5149             endif
5150           enddo
5151
5152         enddo ! iii
5153
5154         dersc(1)=dersc(1)/cos(theti)**2
5155         ddersc(1)=ddersc(1)/cos(theti)**2
5156         ddersc(3)=ddersc(3)
5157
5158         escloci=-(dlog(escloc_i)-emin)
5159         do j=1,3
5160           dersc(j)=dersc(j)/escloc_i
5161         enddo
5162         if (mixed) then
5163           do j=1,3,2
5164             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5165           enddo
5166         endif
5167       return
5168       end
5169 C------------------------------------------------------------------------------
5170       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5171       implicit real*8 (a-h,o-z)
5172       include 'DIMENSIONS'
5173       include 'COMMON.GEO'
5174       include 'COMMON.LOCAL'
5175       include 'COMMON.IOUNITS'
5176       common /sccalc/ time11,time12,time112,theti,it,nlobit
5177       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5178       double precision contr(maxlob)
5179       logical mixed
5180
5181       escloc_i=0.0D0
5182
5183       do j=1,3
5184         dersc(j)=0.0D0
5185       enddo
5186
5187       do j=1,nlobit
5188         do k=1,2
5189           z(k)=x(k)-censc(k,j,it)
5190         enddo
5191         z(3)=dwapi
5192         do k=1,3
5193           Axk=0.0D0
5194           do l=1,3
5195             Axk=Axk+gaussc(l,k,j,it)*z(l)
5196           enddo
5197           Ax(k,j)=Axk
5198         enddo
5199         expfac=0.0D0
5200         do k=1,3
5201           expfac=expfac+Ax(k,j)*z(k)
5202         enddo
5203         contr(j)=expfac
5204       enddo ! j
5205
5206 C As in the case of ebend, we want to avoid underflows in exponentiation and
5207 C subsequent NaNs and INFs in energy calculation.
5208 C Find the largest exponent
5209       emin=contr(1)
5210       do j=1,nlobit
5211         if (emin.gt.contr(j)) emin=contr(j)
5212       enddo
5213       emin=0.5D0*emin
5214
5215 C Compute the contribution to SC energy and derivatives
5216
5217       dersc12=0.0d0
5218       do j=1,nlobit
5219         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5220         escloc_i=escloc_i+expfac
5221         do k=1,2
5222           dersc(k)=dersc(k)+Ax(k,j)*expfac
5223         enddo
5224         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5225      &            +gaussc(1,2,j,it))*expfac
5226         dersc(3)=0.0d0
5227       enddo
5228
5229       dersc(1)=dersc(1)/cos(theti)**2
5230       dersc12=dersc12/cos(theti)**2
5231       escloci=-(dlog(escloc_i)-emin)
5232       do j=1,2
5233         dersc(j)=dersc(j)/escloc_i
5234       enddo
5235       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5236       return
5237       end
5238 #else
5239 c----------------------------------------------------------------------------------
5240       subroutine esc(escloc)
5241 C Calculate the local energy of a side chain and its derivatives in the
5242 C corresponding virtual-bond valence angles THETA and the spherical angles
5243 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5244 C added by Urszula Kozlowska. 07/11/2007
5245 C
5246       implicit real*8 (a-h,o-z)
5247       include 'DIMENSIONS'
5248       include 'COMMON.GEO'
5249       include 'COMMON.LOCAL'
5250       include 'COMMON.VAR'
5251       include 'COMMON.SCROT'
5252       include 'COMMON.INTERACT'
5253       include 'COMMON.DERIV'
5254       include 'COMMON.CHAIN'
5255       include 'COMMON.IOUNITS'
5256       include 'COMMON.NAMES'
5257       include 'COMMON.FFIELD'
5258       include 'COMMON.CONTROL'
5259       include 'COMMON.VECTORS'
5260       double precision x_prime(3),y_prime(3),z_prime(3)
5261      &    , sumene,dsc_i,dp2_i,x(65),
5262      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5263      &    de_dxx,de_dyy,de_dzz,de_dt
5264       double precision s1_t,s1_6_t,s2_t,s2_6_t
5265       double precision
5266      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5267      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5268      & dt_dCi(3),dt_dCi1(3)
5269       common /sccalc/ time11,time12,time112,theti,it,nlobit
5270       delta=0.02d0*pi
5271       escloc=0.0D0
5272       do i=loc_start,loc_end
5273         if (itype(i).eq.ntyp1) cycle
5274         costtab(i+1) =dcos(theta(i+1))
5275         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5276         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5277         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5278         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5279         cosfac=dsqrt(cosfac2)
5280         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5281         sinfac=dsqrt(sinfac2)
5282         it=iabs(itype(i))
5283         if (it.eq.10) goto 1
5284 c
5285 C  Compute the axes of tghe local cartesian coordinates system; store in
5286 c   x_prime, y_prime and z_prime
5287 c
5288         do j=1,3
5289           x_prime(j) = 0.00
5290           y_prime(j) = 0.00
5291           z_prime(j) = 0.00
5292         enddo
5293 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5294 C     &   dc_norm(3,i+nres)
5295         do j = 1,3
5296           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5297           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5298         enddo
5299         do j = 1,3
5300           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5301         enddo
5302 c       write (2,*) "i",i
5303 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5304 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5305 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5306 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5307 c      & " xy",scalar(x_prime(1),y_prime(1)),
5308 c      & " xz",scalar(x_prime(1),z_prime(1)),
5309 c      & " yy",scalar(y_prime(1),y_prime(1)),
5310 c      & " yz",scalar(y_prime(1),z_prime(1)),
5311 c      & " zz",scalar(z_prime(1),z_prime(1))
5312 c
5313 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5314 C to local coordinate system. Store in xx, yy, zz.
5315 c
5316         xx=0.0d0
5317         yy=0.0d0
5318         zz=0.0d0
5319         do j = 1,3
5320           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5321           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5322           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5323         enddo
5324
5325         xxtab(i)=xx
5326         yytab(i)=yy
5327         zztab(i)=zz
5328 C
5329 C Compute the energy of the ith side cbain
5330 C
5331 c        write (2,*) "xx",xx," yy",yy," zz",zz
5332         it=iabs(itype(i))
5333         do j = 1,65
5334           x(j) = sc_parmin(j,it)
5335         enddo
5336 #ifdef CHECK_COORD
5337 Cc diagnostics - remove later
5338         xx1 = dcos(alph(2))
5339         yy1 = dsin(alph(2))*dcos(omeg(2))
5340         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5341         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5342      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5343      &    xx1,yy1,zz1
5344 C,"  --- ", xx_w,yy_w,zz_w
5345 c end diagnostics
5346 #endif
5347         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5348      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5349      &   + x(10)*yy*zz
5350         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5351      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5352      & + x(20)*yy*zz
5353         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5354      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5355      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5356      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5357      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5358      &  +x(40)*xx*yy*zz
5359         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5360      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5361      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5362      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5363      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5364      &  +x(60)*xx*yy*zz
5365         dsc_i   = 0.743d0+x(61)
5366         dp2_i   = 1.9d0+x(62)
5367         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5368      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5369         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5370      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5371         s1=(1+x(63))/(0.1d0 + dscp1)
5372         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5373         s2=(1+x(65))/(0.1d0 + dscp2)
5374         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5375         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5376      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5377 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5378 c     &   sumene4,
5379 c     &   dscp1,dscp2,sumene
5380 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5381         escloc = escloc + sumene
5382 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5383 c     & ,zz,xx,yy
5384 c#define DEBUG
5385 #ifdef DEBUG
5386 C
5387 C This section to check the numerical derivatives of the energy of ith side
5388 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5389 C #define DEBUG in the code to turn it on.
5390 C
5391         write (2,*) "sumene               =",sumene
5392         aincr=1.0d-7
5393         xxsave=xx
5394         xx=xx+aincr
5395         write (2,*) xx,yy,zz
5396         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5397         de_dxx_num=(sumenep-sumene)/aincr
5398         xx=xxsave
5399         write (2,*) "xx+ sumene from enesc=",sumenep
5400         yysave=yy
5401         yy=yy+aincr
5402         write (2,*) xx,yy,zz
5403         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5404         de_dyy_num=(sumenep-sumene)/aincr
5405         yy=yysave
5406         write (2,*) "yy+ sumene from enesc=",sumenep
5407         zzsave=zz
5408         zz=zz+aincr
5409         write (2,*) xx,yy,zz
5410         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5411         de_dzz_num=(sumenep-sumene)/aincr
5412         zz=zzsave
5413         write (2,*) "zz+ sumene from enesc=",sumenep
5414         costsave=cost2tab(i+1)
5415         sintsave=sint2tab(i+1)
5416         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5417         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dt_num=(sumenep-sumene)/aincr
5420         write (2,*) " t+ sumene from enesc=",sumenep
5421         cost2tab(i+1)=costsave
5422         sint2tab(i+1)=sintsave
5423 C End of diagnostics section.
5424 #endif
5425 C
5426 C Compute the gradient of esc
5427 C
5428 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5429         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5430         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5431         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5432         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5433         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5434         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5435         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5436         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5437         pom1=(sumene3*sint2tab(i+1)+sumene1)
5438      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5439         pom2=(sumene4*cost2tab(i+1)+sumene2)
5440      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5441         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5442         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5443      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5444      &  +x(40)*yy*zz
5445         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5446         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5447      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5448      &  +x(60)*yy*zz
5449         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5450      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5451      &        +(pom1+pom2)*pom_dx
5452 #ifdef DEBUG
5453         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5454 #endif
5455 C
5456         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5457         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5458      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5459      &  +x(40)*xx*zz
5460         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5461         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5462      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5463      &  +x(59)*zz**2 +x(60)*xx*zz
5464         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5465      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5466      &        +(pom1-pom2)*pom_dy
5467 #ifdef DEBUG
5468         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5469 #endif
5470 C
5471         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5472      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5473      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5474      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5475      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5476      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5477      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5478      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5479 #ifdef DEBUG
5480         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5481 #endif
5482 C
5483         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5484      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5485      &  +pom1*pom_dt1+pom2*pom_dt2
5486 #ifdef DEBUG
5487         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5488 #endif
5489 c#undef DEBUG
5490 c
5491 C
5492        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5493        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5494        cosfac2xx=cosfac2*xx
5495        sinfac2yy=sinfac2*yy
5496        do k = 1,3
5497          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5498      &      vbld_inv(i+1)
5499          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5500      &      vbld_inv(i)
5501          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5502          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5503 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5504 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5505 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5506 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5507          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5508          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5509          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5510          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5511          dZZ_Ci1(k)=0.0d0
5512          dZZ_Ci(k)=0.0d0
5513          do j=1,3
5514            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5515      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5516            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5517      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5518          enddo
5519
5520          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5521          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5522          dZZ_XYZ(k)=vbld_inv(i+nres)*
5523      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5524 c
5525          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5526          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5527        enddo
5528
5529        do k=1,3
5530          dXX_Ctab(k,i)=dXX_Ci(k)
5531          dXX_C1tab(k,i)=dXX_Ci1(k)
5532          dYY_Ctab(k,i)=dYY_Ci(k)
5533          dYY_C1tab(k,i)=dYY_Ci1(k)
5534          dZZ_Ctab(k,i)=dZZ_Ci(k)
5535          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5536          dXX_XYZtab(k,i)=dXX_XYZ(k)
5537          dYY_XYZtab(k,i)=dYY_XYZ(k)
5538          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5539        enddo
5540
5541        do k = 1,3
5542 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5543 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5544 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5545 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5546 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5547 c     &    dt_dci(k)
5548 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5549 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5550          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5551      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5552          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5553      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5554          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5555      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5556        enddo
5557 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5558 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5559
5560 C to check gradient call subroutine check_grad
5561
5562     1 continue
5563       enddo
5564       return
5565       end
5566 c------------------------------------------------------------------------------
5567       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5568       implicit none
5569       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5570      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5571       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5572      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5573      &   + x(10)*yy*zz
5574       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5575      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5576      & + x(20)*yy*zz
5577       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5578      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5579      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5580      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5581      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5582      &  +x(40)*xx*yy*zz
5583       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5584      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5585      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5586      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5587      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5588      &  +x(60)*xx*yy*zz
5589       dsc_i   = 0.743d0+x(61)
5590       dp2_i   = 1.9d0+x(62)
5591       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5592      &          *(xx*cost2+yy*sint2))
5593       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5594      &          *(xx*cost2-yy*sint2))
5595       s1=(1+x(63))/(0.1d0 + dscp1)
5596       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5597       s2=(1+x(65))/(0.1d0 + dscp2)
5598       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5599       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5600      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5601       enesc=sumene
5602       return
5603       end
5604 #endif
5605 c------------------------------------------------------------------------------
5606       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5607 C
5608 C This procedure calculates two-body contact function g(rij) and its derivative:
5609 C
5610 C           eps0ij                                     !       x < -1
5611 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5612 C            0                                         !       x > 1
5613 C
5614 C where x=(rij-r0ij)/delta
5615 C
5616 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5617 C
5618       implicit none
5619       double precision rij,r0ij,eps0ij,fcont,fprimcont
5620       double precision x,x2,x4,delta
5621 c     delta=0.02D0*r0ij
5622 c      delta=0.2D0*r0ij
5623       x=(rij-r0ij)/delta
5624       if (x.lt.-1.0D0) then
5625         fcont=eps0ij
5626         fprimcont=0.0D0
5627       else if (x.le.1.0D0) then
5628         x2=x*x
5629         x4=x2*x2
5630         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5631         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5632       else
5633         fcont=0.0D0
5634         fprimcont=0.0D0
5635       endif
5636       return
5637       end
5638 c------------------------------------------------------------------------------
5639       subroutine splinthet(theti,delta,ss,ssder)
5640       implicit real*8 (a-h,o-z)
5641       include 'DIMENSIONS'
5642       include 'COMMON.VAR'
5643       include 'COMMON.GEO'
5644       thetup=pi-delta
5645       thetlow=delta
5646       if (theti.gt.pipol) then
5647         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5648       else
5649         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5650         ssder=-ssder
5651       endif
5652       return
5653       end
5654 c------------------------------------------------------------------------------
5655       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5656       implicit none
5657       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5658       double precision ksi,ksi2,ksi3,a1,a2,a3
5659       a1=fprim0*delta/(f1-f0)
5660       a2=3.0d0-2.0d0*a1
5661       a3=a1-2.0d0
5662       ksi=(x-x0)/delta
5663       ksi2=ksi*ksi
5664       ksi3=ksi2*ksi
5665       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5666       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5667       return
5668       end
5669 c------------------------------------------------------------------------------
5670       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5671       implicit none
5672       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5673       double precision ksi,ksi2,ksi3,a1,a2,a3
5674       ksi=(x-x0)/delta
5675       ksi2=ksi*ksi
5676       ksi3=ksi2*ksi
5677       a1=fprim0x*delta
5678       a2=3*(f1x-f0x)-2*fprim0x*delta
5679       a3=fprim0x*delta-2*(f1x-f0x)
5680       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5681       return
5682       end
5683 C-----------------------------------------------------------------------------
5684 #ifdef CRYST_TOR
5685 C-----------------------------------------------------------------------------
5686       subroutine etor(etors,edihcnstr)
5687       implicit real*8 (a-h,o-z)
5688       include 'DIMENSIONS'
5689       include 'COMMON.VAR'
5690       include 'COMMON.GEO'
5691       include 'COMMON.LOCAL'
5692       include 'COMMON.TORSION'
5693       include 'COMMON.INTERACT'
5694       include 'COMMON.DERIV'
5695       include 'COMMON.CHAIN'
5696       include 'COMMON.NAMES'
5697       include 'COMMON.IOUNITS'
5698       include 'COMMON.FFIELD'
5699       include 'COMMON.TORCNSTR'
5700       include 'COMMON.CONTROL'
5701       logical lprn
5702 C Set lprn=.true. for debugging
5703       lprn=.false.
5704 c      lprn=.true.
5705       etors=0.0D0
5706       do i=iphi_start,iphi_end
5707       etors_ii=0.0D0
5708         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5709      &      .or. itype(i).eq.ntyp1) cycle
5710         itori=itortyp(itype(i-2))
5711         itori1=itortyp(itype(i-1))
5712         phii=phi(i)
5713         gloci=0.0D0
5714 C Proline-Proline pair is a special case...
5715         if (itori.eq.3 .and. itori1.eq.3) then
5716           if (phii.gt.-dwapi3) then
5717             cosphi=dcos(3*phii)
5718             fac=1.0D0/(1.0D0-cosphi)
5719             etorsi=v1(1,3,3)*fac
5720             etorsi=etorsi+etorsi
5721             etors=etors+etorsi-v1(1,3,3)
5722             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5723             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5724           endif
5725           do j=1,3
5726             v1ij=v1(j+1,itori,itori1)
5727             v2ij=v2(j+1,itori,itori1)
5728             cosphi=dcos(j*phii)
5729             sinphi=dsin(j*phii)
5730             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5731             if (energy_dec) etors_ii=etors_ii+
5732      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5733             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5734           enddo
5735         else
5736           do j=1,nterm_old
5737             v1ij=v1(j,itori,itori1)
5738             v2ij=v2(j,itori,itori1)
5739             cosphi=dcos(j*phii)
5740             sinphi=dsin(j*phii)
5741             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5742             if (energy_dec) etors_ii=etors_ii+
5743      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5744             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5745           enddo
5746         endif
5747         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5748              'etor',i,etors_ii
5749         if (lprn)
5750      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5751      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5752      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5753         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5754 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5755       enddo
5756 ! 6/20/98 - dihedral angle constraints
5757       edihcnstr=0.0d0
5758       do i=1,ndih_constr
5759         itori=idih_constr(i)
5760         phii=phi(itori)
5761         difi=phii-phi0(i)
5762         if (difi.gt.drange(i)) then
5763           difi=difi-drange(i)
5764           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5765           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5766         else if (difi.lt.-drange(i)) then
5767           difi=difi+drange(i)
5768           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5769           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5770         endif
5771 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5772 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5773       enddo
5774 !      write (iout,*) 'edihcnstr',edihcnstr
5775       return
5776       end
5777 c------------------------------------------------------------------------------
5778       subroutine etor_d(etors_d)
5779       etors_d=0.0d0
5780       return
5781       end
5782 c----------------------------------------------------------------------------
5783 #else
5784       subroutine etor(etors,edihcnstr)
5785       implicit real*8 (a-h,o-z)
5786       include 'DIMENSIONS'
5787       include 'COMMON.VAR'
5788       include 'COMMON.GEO'
5789       include 'COMMON.LOCAL'
5790       include 'COMMON.TORSION'
5791       include 'COMMON.INTERACT'
5792       include 'COMMON.DERIV'
5793       include 'COMMON.CHAIN'
5794       include 'COMMON.NAMES'
5795       include 'COMMON.IOUNITS'
5796       include 'COMMON.FFIELD'
5797       include 'COMMON.TORCNSTR'
5798       include 'COMMON.CONTROL'
5799       logical lprn
5800 C Set lprn=.true. for debugging
5801       lprn=.false.
5802 c     lprn=.true.
5803       etors=0.0D0
5804       do i=iphi_start,iphi_end
5805         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5806      &       .or. itype(i).eq.ntyp1) cycle
5807         etors_ii=0.0D0
5808          if (iabs(itype(i)).eq.20) then
5809          iblock=2
5810          else
5811          iblock=1
5812          endif
5813         itori=itortyp(itype(i-2))
5814         itori1=itortyp(itype(i-1))
5815         phii=phi(i)
5816         gloci=0.0D0
5817 C Regular cosine and sine terms
5818         do j=1,nterm(itori,itori1,iblock)
5819           v1ij=v1(j,itori,itori1,iblock)
5820           v2ij=v2(j,itori,itori1,iblock)
5821           cosphi=dcos(j*phii)
5822           sinphi=dsin(j*phii)
5823           etors=etors+v1ij*cosphi+v2ij*sinphi
5824           if (energy_dec) etors_ii=etors_ii+
5825      &                v1ij*cosphi+v2ij*sinphi
5826           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5827         enddo
5828 C Lorentz terms
5829 C                         v1
5830 C  E = SUM ----------------------------------- - v1
5831 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5832 C
5833         cosphi=dcos(0.5d0*phii)
5834         sinphi=dsin(0.5d0*phii)
5835         do j=1,nlor(itori,itori1,iblock)
5836           vl1ij=vlor1(j,itori,itori1)
5837           vl2ij=vlor2(j,itori,itori1)
5838           vl3ij=vlor3(j,itori,itori1)
5839           pom=vl2ij*cosphi+vl3ij*sinphi
5840           pom1=1.0d0/(pom*pom+1.0d0)
5841           etors=etors+vl1ij*pom1
5842           if (energy_dec) etors_ii=etors_ii+
5843      &                vl1ij*pom1
5844           pom=-pom*pom1*pom1
5845           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5846         enddo
5847 C Subtract the constant term
5848         etors=etors-v0(itori,itori1,iblock)
5849           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5850      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5851         if (lprn)
5852      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5853      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5854      &  (v1(j,itori,itori1,iblock),j=1,6),
5855      &  (v2(j,itori,itori1,iblock),j=1,6)
5856         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5857 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5858       enddo
5859 ! 6/20/98 - dihedral angle constraints
5860       edihcnstr=0.0d0
5861 c      do i=1,ndih_constr
5862       do i=idihconstr_start,idihconstr_end
5863         itori=idih_constr(i)
5864         phii=phi(itori)
5865         difi=pinorm(phii-phi0(i))
5866         if (difi.gt.drange(i)) then
5867           difi=difi-drange(i)
5868           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5870         else if (difi.lt.-drange(i)) then
5871           difi=difi+drange(i)
5872           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5873           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5874         else
5875           difi=0.0
5876         endif
5877 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5878 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5879 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5880       enddo
5881 cd       write (iout,*) 'edihcnstr',edihcnstr
5882       return
5883       end
5884 c----------------------------------------------------------------------------
5885       subroutine etor_d(etors_d)
5886 C 6/23/01 Compute double torsional energy
5887       implicit real*8 (a-h,o-z)
5888       include 'DIMENSIONS'
5889       include 'COMMON.VAR'
5890       include 'COMMON.GEO'
5891       include 'COMMON.LOCAL'
5892       include 'COMMON.TORSION'
5893       include 'COMMON.INTERACT'
5894       include 'COMMON.DERIV'
5895       include 'COMMON.CHAIN'
5896       include 'COMMON.NAMES'
5897       include 'COMMON.IOUNITS'
5898       include 'COMMON.FFIELD'
5899       include 'COMMON.TORCNSTR'
5900       logical lprn
5901 C Set lprn=.true. for debugging
5902       lprn=.false.
5903 c     lprn=.true.
5904       etors_d=0.0D0
5905 c      write(iout,*) "a tu??"
5906       do i=iphid_start,iphid_end
5907         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5908      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5909         itori=itortyp(itype(i-2))
5910         itori1=itortyp(itype(i-1))
5911         itori2=itortyp(itype(i))
5912         phii=phi(i)
5913         phii1=phi(i+1)
5914         gloci1=0.0D0
5915         gloci2=0.0D0
5916         iblock=1
5917         if (iabs(itype(i+1)).eq.20) iblock=2
5918
5919 C Regular cosine and sine terms
5920         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5921           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5922           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5923           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5924           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5925           cosphi1=dcos(j*phii)
5926           sinphi1=dsin(j*phii)
5927           cosphi2=dcos(j*phii1)
5928           sinphi2=dsin(j*phii1)
5929           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5930      &     v2cij*cosphi2+v2sij*sinphi2
5931           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5932           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5933         enddo
5934         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5935           do l=1,k-1
5936             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5937             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5938             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5939             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5940             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5941             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5942             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5943             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5944             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5945      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5946             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5947      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5948             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5949      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5950           enddo
5951         enddo
5952         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5953         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5954       enddo
5955       return
5956       end
5957 #endif
5958 c------------------------------------------------------------------------------
5959       subroutine eback_sc_corr(esccor)
5960 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5961 c        conformational states; temporarily implemented as differences
5962 c        between UNRES torsional potentials (dependent on three types of
5963 c        residues) and the torsional potentials dependent on all 20 types
5964 c        of residues computed from AM1  energy surfaces of terminally-blocked
5965 c        amino-acid residues.
5966       implicit real*8 (a-h,o-z)
5967       include 'DIMENSIONS'
5968       include 'COMMON.VAR'
5969       include 'COMMON.GEO'
5970       include 'COMMON.LOCAL'
5971       include 'COMMON.TORSION'
5972       include 'COMMON.SCCOR'
5973       include 'COMMON.INTERACT'
5974       include 'COMMON.DERIV'
5975       include 'COMMON.CHAIN'
5976       include 'COMMON.NAMES'
5977       include 'COMMON.IOUNITS'
5978       include 'COMMON.FFIELD'
5979       include 'COMMON.CONTROL'
5980       logical lprn
5981 C Set lprn=.true. for debugging
5982       lprn=.false.
5983 c      lprn=.true.
5984 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5985       esccor=0.0D0
5986       do i=itau_start,itau_end
5987         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5988         esccor_ii=0.0D0
5989         isccori=isccortyp(itype(i-2))
5990         isccori1=isccortyp(itype(i-1))
5991 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5992         phii=phi(i)
5993         do intertyp=1,3 !intertyp
5994 cc Added 09 May 2012 (Adasko)
5995 cc  Intertyp means interaction type of backbone mainchain correlation:
5996 c   1 = SC...Ca...Ca...Ca
5997 c   2 = Ca...Ca...Ca...SC
5998 c   3 = SC...Ca...Ca...SCi
5999         gloci=0.0D0
6000         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6001      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6002      &      (itype(i-1).eq.ntyp1)))
6003      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6004      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6005      &     .or.(itype(i).eq.ntyp1)))
6006      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6007      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6008      &      (itype(i-3).eq.ntyp1)))) cycle
6009         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6010         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6011      & cycle
6012        do j=1,nterm_sccor(isccori,isccori1)
6013           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6014           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6015           cosphi=dcos(j*tauangle(intertyp,i))
6016           sinphi=dsin(j*tauangle(intertyp,i))
6017           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6018           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6019         enddo
6020 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6021         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6022         if (lprn)
6023      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6024      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6025      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6026      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6027         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6028        enddo !intertyp
6029       enddo
6030
6031       return
6032       end
6033 c----------------------------------------------------------------------------
6034       subroutine multibody(ecorr)
6035 C This subroutine calculates multi-body contributions to energy following
6036 C the idea of Skolnick et al. If side chains I and J make a contact and
6037 C at the same time side chains I+1 and J+1 make a contact, an extra
6038 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6039       implicit real*8 (a-h,o-z)
6040       include 'DIMENSIONS'
6041       include 'COMMON.IOUNITS'
6042       include 'COMMON.DERIV'
6043       include 'COMMON.INTERACT'
6044       include 'COMMON.CONTACTS'
6045       double precision gx(3),gx1(3)
6046       logical lprn
6047
6048 C Set lprn=.true. for debugging
6049       lprn=.false.
6050
6051       if (lprn) then
6052         write (iout,'(a)') 'Contact function values:'
6053         do i=nnt,nct-2
6054           write (iout,'(i2,20(1x,i2,f10.5))')
6055      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6056         enddo
6057       endif
6058       ecorr=0.0D0
6059       do i=nnt,nct
6060         do j=1,3
6061           gradcorr(j,i)=0.0D0
6062           gradxorr(j,i)=0.0D0
6063         enddo
6064       enddo
6065       do i=nnt,nct-2
6066
6067         DO ISHIFT = 3,4
6068
6069         i1=i+ishift
6070         num_conti=num_cont(i)
6071         num_conti1=num_cont(i1)
6072         do jj=1,num_conti
6073           j=jcont(jj,i)
6074           do kk=1,num_conti1
6075             j1=jcont(kk,i1)
6076             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6077 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6078 cd   &                   ' ishift=',ishift
6079 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6080 C The system gains extra energy.
6081               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6082             endif   ! j1==j+-ishift
6083           enddo     ! kk
6084         enddo       ! jj
6085
6086         ENDDO ! ISHIFT
6087
6088       enddo         ! i
6089       return
6090       end
6091 c------------------------------------------------------------------------------
6092       double precision function esccorr(i,j,k,l,jj,kk)
6093       implicit real*8 (a-h,o-z)
6094       include 'DIMENSIONS'
6095       include 'COMMON.IOUNITS'
6096       include 'COMMON.DERIV'
6097       include 'COMMON.INTERACT'
6098       include 'COMMON.CONTACTS'
6099       double precision gx(3),gx1(3)
6100       logical lprn
6101       lprn=.false.
6102       eij=facont(jj,i)
6103       ekl=facont(kk,k)
6104 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6105 C Calculate the multi-body contribution to energy.
6106 C Calculate multi-body contributions to the gradient.
6107 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6108 cd   & k,l,(gacont(m,kk,k),m=1,3)
6109       do m=1,3
6110         gx(m) =ekl*gacont(m,jj,i)
6111         gx1(m)=eij*gacont(m,kk,k)
6112         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6113         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6114         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6115         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6116       enddo
6117       do m=i,j-1
6118         do ll=1,3
6119           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6120         enddo
6121       enddo
6122       do m=k,l-1
6123         do ll=1,3
6124           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6125         enddo
6126       enddo
6127       esccorr=-eij*ekl
6128       return
6129       end
6130 c------------------------------------------------------------------------------
6131       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6132 C This subroutine calculates multi-body contributions to hydrogen-bonding
6133       implicit real*8 (a-h,o-z)
6134       include 'DIMENSIONS'
6135       include 'COMMON.IOUNITS'
6136 #ifdef MPI
6137       include "mpif.h"
6138       parameter (max_cont=maxconts)
6139       parameter (max_dim=26)
6140       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6141       double precision zapas(max_dim,maxconts,max_fg_procs),
6142      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6143       common /przechowalnia/ zapas
6144       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6145      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6146 #endif
6147       include 'COMMON.SETUP'
6148       include 'COMMON.FFIELD'
6149       include 'COMMON.DERIV'
6150       include 'COMMON.INTERACT'
6151       include 'COMMON.CONTACTS'
6152       include 'COMMON.CONTROL'
6153       include 'COMMON.LOCAL'
6154       double precision gx(3),gx1(3),time00
6155       logical lprn,ldone
6156
6157 C Set lprn=.true. for debugging
6158       lprn=.false.
6159 #ifdef MPI
6160       n_corr=0
6161       n_corr1=0
6162       if (nfgtasks.le.1) goto 30
6163       if (lprn) then
6164         write (iout,'(a)') 'Contact function values before RECEIVE:'
6165         do i=nnt,nct-2
6166           write (iout,'(2i3,50(1x,i2,f5.2))')
6167      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6168      &    j=1,num_cont_hb(i))
6169         enddo
6170       endif
6171       call flush(iout)
6172       do i=1,ntask_cont_from
6173         ncont_recv(i)=0
6174       enddo
6175       do i=1,ntask_cont_to
6176         ncont_sent(i)=0
6177       enddo
6178 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6179 c     & ntask_cont_to
6180 C Make the list of contacts to send to send to other procesors
6181 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6182 c      call flush(iout)
6183       do i=iturn3_start,iturn3_end
6184 c        write (iout,*) "make contact list turn3",i," num_cont",
6185 c     &    num_cont_hb(i)
6186         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6187       enddo
6188       do i=iturn4_start,iturn4_end
6189 c        write (iout,*) "make contact list turn4",i," num_cont",
6190 c     &   num_cont_hb(i)
6191         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6192       enddo
6193       do ii=1,nat_sent
6194         i=iat_sent(ii)
6195 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6196 c     &    num_cont_hb(i)
6197         do j=1,num_cont_hb(i)
6198         do k=1,4
6199           jjc=jcont_hb(j,i)
6200           iproc=iint_sent_local(k,jjc,ii)
6201 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6202           if (iproc.gt.0) then
6203             ncont_sent(iproc)=ncont_sent(iproc)+1
6204             nn=ncont_sent(iproc)
6205             zapas(1,nn,iproc)=i
6206             zapas(2,nn,iproc)=jjc
6207             zapas(3,nn,iproc)=facont_hb(j,i)
6208             zapas(4,nn,iproc)=ees0p(j,i)
6209             zapas(5,nn,iproc)=ees0m(j,i)
6210             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6211             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6212             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6213             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6214             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6215             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6216             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6217             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6218             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6219             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6220             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6221             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6222             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6223             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6224             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6225             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6226             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6227             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6228             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6229             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6230             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6231           endif
6232         enddo
6233         enddo
6234       enddo
6235       if (lprn) then
6236       write (iout,*)
6237      &  "Numbers of contacts to be sent to other processors",
6238      &  (ncont_sent(i),i=1,ntask_cont_to)
6239       write (iout,*) "Contacts sent"
6240       do ii=1,ntask_cont_to
6241         nn=ncont_sent(ii)
6242         iproc=itask_cont_to(ii)
6243         write (iout,*) nn," contacts to processor",iproc,
6244      &   " of CONT_TO_COMM group"
6245         do i=1,nn
6246           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6247         enddo
6248       enddo
6249       call flush(iout)
6250       endif
6251       CorrelType=477
6252       CorrelID=fg_rank+1
6253       CorrelType1=478
6254       CorrelID1=nfgtasks+fg_rank+1
6255       ireq=0
6256 C Receive the numbers of needed contacts from other processors
6257       do ii=1,ntask_cont_from
6258         iproc=itask_cont_from(ii)
6259         ireq=ireq+1
6260         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6261      &    FG_COMM,req(ireq),IERR)
6262       enddo
6263 c      write (iout,*) "IRECV ended"
6264 c      call flush(iout)
6265 C Send the number of contacts needed by other processors
6266       do ii=1,ntask_cont_to
6267         iproc=itask_cont_to(ii)
6268         ireq=ireq+1
6269         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6270      &    FG_COMM,req(ireq),IERR)
6271       enddo
6272 c      write (iout,*) "ISEND ended"
6273 c      write (iout,*) "number of requests (nn)",ireq
6274       call flush(iout)
6275       if (ireq.gt.0)
6276      &  call MPI_Waitall(ireq,req,status_array,ierr)
6277 c      write (iout,*)
6278 c     &  "Numbers of contacts to be received from other processors",
6279 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6280 c      call flush(iout)
6281 C Receive contacts
6282       ireq=0
6283       do ii=1,ntask_cont_from
6284         iproc=itask_cont_from(ii)
6285         nn=ncont_recv(ii)
6286 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6287 c     &   " of CONT_TO_COMM group"
6288         call flush(iout)
6289         if (nn.gt.0) then
6290           ireq=ireq+1
6291           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6292      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6293 c          write (iout,*) "ireq,req",ireq,req(ireq)
6294         endif
6295       enddo
6296 C Send the contacts to processors that need them
6297       do ii=1,ntask_cont_to
6298         iproc=itask_cont_to(ii)
6299         nn=ncont_sent(ii)
6300 c        write (iout,*) nn," contacts to processor",iproc,
6301 c     &   " of CONT_TO_COMM group"
6302         if (nn.gt.0) then
6303           ireq=ireq+1
6304           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6305      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6306 c          write (iout,*) "ireq,req",ireq,req(ireq)
6307 c          do i=1,nn
6308 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6309 c          enddo
6310         endif
6311       enddo
6312 c      write (iout,*) "number of requests (contacts)",ireq
6313 c      write (iout,*) "req",(req(i),i=1,4)
6314 c      call flush(iout)
6315       if (ireq.gt.0)
6316      & call MPI_Waitall(ireq,req,status_array,ierr)
6317       do iii=1,ntask_cont_from
6318         iproc=itask_cont_from(iii)
6319         nn=ncont_recv(iii)
6320         if (lprn) then
6321         write (iout,*) "Received",nn," contacts from processor",iproc,
6322      &   " of CONT_FROM_COMM group"
6323         call flush(iout)
6324         do i=1,nn
6325           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6326         enddo
6327         call flush(iout)
6328         endif
6329         do i=1,nn
6330           ii=zapas_recv(1,i,iii)
6331 c Flag the received contacts to prevent double-counting
6332           jj=-zapas_recv(2,i,iii)
6333 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6334 c          call flush(iout)
6335           nnn=num_cont_hb(ii)+1
6336           num_cont_hb(ii)=nnn
6337           jcont_hb(nnn,ii)=jj
6338           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6339           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6340           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6341           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6342           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6343           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6344           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6345           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6346           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6347           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6348           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6349           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6350           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6351           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6352           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6353           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6354           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6355           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6356           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6357           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6358           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6359           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6360           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6361           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6362         enddo
6363       enddo
6364       call flush(iout)
6365       if (lprn) then
6366         write (iout,'(a)') 'Contact function values after receive:'
6367         do i=nnt,nct-2
6368           write (iout,'(2i3,50(1x,i3,f5.2))')
6369      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6370      &    j=1,num_cont_hb(i))
6371         enddo
6372         call flush(iout)
6373       endif
6374    30 continue
6375 #endif
6376       if (lprn) then
6377         write (iout,'(a)') 'Contact function values:'
6378         do i=nnt,nct-2
6379           write (iout,'(2i3,50(1x,i3,f5.2))')
6380      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6381      &    j=1,num_cont_hb(i))
6382         enddo
6383       endif
6384       ecorr=0.0D0
6385 C Remove the loop below after debugging !!!
6386       do i=nnt,nct
6387         do j=1,3
6388           gradcorr(j,i)=0.0D0
6389           gradxorr(j,i)=0.0D0
6390         enddo
6391       enddo
6392 C Calculate the local-electrostatic correlation terms
6393       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6394         i1=i+1
6395         num_conti=num_cont_hb(i)
6396         num_conti1=num_cont_hb(i+1)
6397         do jj=1,num_conti
6398           j=jcont_hb(jj,i)
6399           jp=iabs(j)
6400           do kk=1,num_conti1
6401             j1=jcont_hb(kk,i1)
6402             jp1=iabs(j1)
6403 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6404 c     &         ' jj=',jj,' kk=',kk
6405             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6406      &          .or. j.lt.0 .and. j1.gt.0) .and.
6407      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6408 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6409 C The system gains extra energy.
6410               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6411               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6412      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6413               n_corr=n_corr+1
6414             else if (j1.eq.j) then
6415 C Contacts I-J and I-(J+1) occur simultaneously.
6416 C The system loses extra energy.
6417 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6418             endif
6419           enddo ! kk
6420           do kk=1,num_conti
6421             j1=jcont_hb(kk,i)
6422 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6423 c    &         ' jj=',jj,' kk=',kk
6424             if (j1.eq.j+1) then
6425 C Contacts I-J and (I+1)-J occur simultaneously.
6426 C The system loses extra energy.
6427 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6428             endif ! j1==j+1
6429           enddo ! kk
6430         enddo ! jj
6431       enddo ! i
6432       return
6433       end
6434 c------------------------------------------------------------------------------
6435       subroutine add_hb_contact(ii,jj,itask)
6436       implicit real*8 (a-h,o-z)
6437       include "DIMENSIONS"
6438       include "COMMON.IOUNITS"
6439       integer max_cont
6440       integer max_dim
6441       parameter (max_cont=maxconts)
6442       parameter (max_dim=26)
6443       include "COMMON.CONTACTS"
6444       double precision zapas(max_dim,maxconts,max_fg_procs),
6445      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6446       common /przechowalnia/ zapas
6447       integer i,j,ii,jj,iproc,itask(4),nn
6448 c      write (iout,*) "itask",itask
6449       do i=1,2
6450         iproc=itask(i)
6451         if (iproc.gt.0) then
6452           do j=1,num_cont_hb(ii)
6453             jjc=jcont_hb(j,ii)
6454 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6455             if (jjc.eq.jj) then
6456               ncont_sent(iproc)=ncont_sent(iproc)+1
6457               nn=ncont_sent(iproc)
6458               zapas(1,nn,iproc)=ii
6459               zapas(2,nn,iproc)=jjc
6460               zapas(3,nn,iproc)=facont_hb(j,ii)
6461               zapas(4,nn,iproc)=ees0p(j,ii)
6462               zapas(5,nn,iproc)=ees0m(j,ii)
6463               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6464               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6465               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6466               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6467               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6468               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6469               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6470               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6471               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6472               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6473               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6474               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6475               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6476               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6477               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6478               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6479               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6480               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6481               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6482               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6483               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6484               exit
6485             endif
6486           enddo
6487         endif
6488       enddo
6489       return
6490       end
6491 c------------------------------------------------------------------------------
6492       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6493      &  n_corr1)
6494 C This subroutine calculates multi-body contributions to hydrogen-bonding
6495       implicit real*8 (a-h,o-z)
6496       include 'DIMENSIONS'
6497       include 'COMMON.IOUNITS'
6498 #ifdef MPI
6499       include "mpif.h"
6500       parameter (max_cont=maxconts)
6501       parameter (max_dim=70)
6502       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6503       double precision zapas(max_dim,maxconts,max_fg_procs),
6504      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6505       common /przechowalnia/ zapas
6506       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6507      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6508 #endif
6509       include 'COMMON.SETUP'
6510       include 'COMMON.FFIELD'
6511       include 'COMMON.DERIV'
6512       include 'COMMON.LOCAL'
6513       include 'COMMON.INTERACT'
6514       include 'COMMON.CONTACTS'
6515       include 'COMMON.CHAIN'
6516       include 'COMMON.CONTROL'
6517       double precision gx(3),gx1(3)
6518       integer num_cont_hb_old(maxres)
6519       logical lprn,ldone
6520       double precision eello4,eello5,eelo6,eello_turn6
6521       external eello4,eello5,eello6,eello_turn6
6522 C Set lprn=.true. for debugging
6523       lprn=.false.
6524       eturn6=0.0d0
6525 #ifdef MPI
6526       do i=1,nres
6527         num_cont_hb_old(i)=num_cont_hb(i)
6528       enddo
6529       n_corr=0
6530       n_corr1=0
6531       if (nfgtasks.le.1) goto 30
6532       if (lprn) then
6533         write (iout,'(a)') 'Contact function values before RECEIVE:'
6534         do i=nnt,nct-2
6535           write (iout,'(2i3,50(1x,i2,f5.2))')
6536      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6537      &    j=1,num_cont_hb(i))
6538         enddo
6539       endif
6540       call flush(iout)
6541       do i=1,ntask_cont_from
6542         ncont_recv(i)=0
6543       enddo
6544       do i=1,ntask_cont_to
6545         ncont_sent(i)=0
6546       enddo
6547 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6548 c     & ntask_cont_to
6549 C Make the list of contacts to send to send to other procesors
6550       do i=iturn3_start,iturn3_end
6551 c        write (iout,*) "make contact list turn3",i," num_cont",
6552 c     &    num_cont_hb(i)
6553         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6554       enddo
6555       do i=iturn4_start,iturn4_end
6556 c        write (iout,*) "make contact list turn4",i," num_cont",
6557 c     &   num_cont_hb(i)
6558         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6559       enddo
6560       do ii=1,nat_sent
6561         i=iat_sent(ii)
6562 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6563 c     &    num_cont_hb(i)
6564         do j=1,num_cont_hb(i)
6565         do k=1,4
6566           jjc=jcont_hb(j,i)
6567           iproc=iint_sent_local(k,jjc,ii)
6568 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6569           if (iproc.ne.0) then
6570             ncont_sent(iproc)=ncont_sent(iproc)+1
6571             nn=ncont_sent(iproc)
6572             zapas(1,nn,iproc)=i
6573             zapas(2,nn,iproc)=jjc
6574             zapas(3,nn,iproc)=d_cont(j,i)
6575             ind=3
6576             do kk=1,3
6577               ind=ind+1
6578               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6579             enddo
6580             do kk=1,2
6581               do ll=1,2
6582                 ind=ind+1
6583                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6584               enddo
6585             enddo
6586             do jj=1,5
6587               do kk=1,3
6588                 do ll=1,2
6589                   do mm=1,2
6590                     ind=ind+1
6591                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6592                   enddo
6593                 enddo
6594               enddo
6595             enddo
6596           endif
6597         enddo
6598         enddo
6599       enddo
6600       if (lprn) then
6601       write (iout,*)
6602      &  "Numbers of contacts to be sent to other processors",
6603      &  (ncont_sent(i),i=1,ntask_cont_to)
6604       write (iout,*) "Contacts sent"
6605       do ii=1,ntask_cont_to
6606         nn=ncont_sent(ii)
6607         iproc=itask_cont_to(ii)
6608         write (iout,*) nn," contacts to processor",iproc,
6609      &   " of CONT_TO_COMM group"
6610         do i=1,nn
6611           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6612         enddo
6613       enddo
6614       call flush(iout)
6615       endif
6616       CorrelType=477
6617       CorrelID=fg_rank+1
6618       CorrelType1=478
6619       CorrelID1=nfgtasks+fg_rank+1
6620       ireq=0
6621 C Receive the numbers of needed contacts from other processors
6622       do ii=1,ntask_cont_from
6623         iproc=itask_cont_from(ii)
6624         ireq=ireq+1
6625         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6626      &    FG_COMM,req(ireq),IERR)
6627       enddo
6628 c      write (iout,*) "IRECV ended"
6629 c      call flush(iout)
6630 C Send the number of contacts needed by other processors
6631       do ii=1,ntask_cont_to
6632         iproc=itask_cont_to(ii)
6633         ireq=ireq+1
6634         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6635      &    FG_COMM,req(ireq),IERR)
6636       enddo
6637 c      write (iout,*) "ISEND ended"
6638 c      write (iout,*) "number of requests (nn)",ireq
6639       call flush(iout)
6640       if (ireq.gt.0)
6641      &  call MPI_Waitall(ireq,req,status_array,ierr)
6642 c      write (iout,*)
6643 c     &  "Numbers of contacts to be received from other processors",
6644 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6645 c      call flush(iout)
6646 C Receive contacts
6647       ireq=0
6648       do ii=1,ntask_cont_from
6649         iproc=itask_cont_from(ii)
6650         nn=ncont_recv(ii)
6651 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6652 c     &   " of CONT_TO_COMM group"
6653         call flush(iout)
6654         if (nn.gt.0) then
6655           ireq=ireq+1
6656           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6657      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6658 c          write (iout,*) "ireq,req",ireq,req(ireq)
6659         endif
6660       enddo
6661 C Send the contacts to processors that need them
6662       do ii=1,ntask_cont_to
6663         iproc=itask_cont_to(ii)
6664         nn=ncont_sent(ii)
6665 c        write (iout,*) nn," contacts to processor",iproc,
6666 c     &   " of CONT_TO_COMM group"
6667         if (nn.gt.0) then
6668           ireq=ireq+1
6669           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6670      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6671 c          write (iout,*) "ireq,req",ireq,req(ireq)
6672 c          do i=1,nn
6673 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6674 c          enddo
6675         endif
6676       enddo
6677 c      write (iout,*) "number of requests (contacts)",ireq
6678 c      write (iout,*) "req",(req(i),i=1,4)
6679 c      call flush(iout)
6680       if (ireq.gt.0)
6681      & call MPI_Waitall(ireq,req,status_array,ierr)
6682       do iii=1,ntask_cont_from
6683         iproc=itask_cont_from(iii)
6684         nn=ncont_recv(iii)
6685         if (lprn) then
6686         write (iout,*) "Received",nn," contacts from processor",iproc,
6687      &   " of CONT_FROM_COMM group"
6688         call flush(iout)
6689         do i=1,nn
6690           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6691         enddo
6692         call flush(iout)
6693         endif
6694         do i=1,nn
6695           ii=zapas_recv(1,i,iii)
6696 c Flag the received contacts to prevent double-counting
6697           jj=-zapas_recv(2,i,iii)
6698 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6699 c          call flush(iout)
6700           nnn=num_cont_hb(ii)+1
6701           num_cont_hb(ii)=nnn
6702           jcont_hb(nnn,ii)=jj
6703           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6704           ind=3
6705           do kk=1,3
6706             ind=ind+1
6707             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6708           enddo
6709           do kk=1,2
6710             do ll=1,2
6711               ind=ind+1
6712               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6713             enddo
6714           enddo
6715           do jj=1,5
6716             do kk=1,3
6717               do ll=1,2
6718                 do mm=1,2
6719                   ind=ind+1
6720                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6721                 enddo
6722               enddo
6723             enddo
6724           enddo
6725         enddo
6726       enddo
6727       call flush(iout)
6728       if (lprn) then
6729         write (iout,'(a)') 'Contact function values after receive:'
6730         do i=nnt,nct-2
6731           write (iout,'(2i3,50(1x,i3,5f6.3))')
6732      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6733      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6734         enddo
6735         call flush(iout)
6736       endif
6737    30 continue
6738 #endif
6739       if (lprn) then
6740         write (iout,'(a)') 'Contact function values:'
6741         do i=nnt,nct-2
6742           write (iout,'(2i3,50(1x,i2,5f6.3))')
6743      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6744      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6745         enddo
6746       endif
6747       ecorr=0.0D0
6748       ecorr5=0.0d0
6749       ecorr6=0.0d0
6750 C Remove the loop below after debugging !!!
6751       do i=nnt,nct
6752         do j=1,3
6753           gradcorr(j,i)=0.0D0
6754           gradxorr(j,i)=0.0D0
6755         enddo
6756       enddo
6757 C Calculate the dipole-dipole interaction energies
6758       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6759       do i=iatel_s,iatel_e+1
6760         num_conti=num_cont_hb(i)
6761         do jj=1,num_conti
6762           j=jcont_hb(jj,i)
6763 #ifdef MOMENT
6764           call dipole(i,j,jj)
6765 #endif
6766         enddo
6767       enddo
6768       endif
6769 C Calculate the local-electrostatic correlation terms
6770 c                write (iout,*) "gradcorr5 in eello5 before loop"
6771 c                do iii=1,nres
6772 c                  write (iout,'(i5,3f10.5)')
6773 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6774 c                enddo
6775       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6776 c        write (iout,*) "corr loop i",i
6777         i1=i+1
6778         num_conti=num_cont_hb(i)
6779         num_conti1=num_cont_hb(i+1)
6780         do jj=1,num_conti
6781           j=jcont_hb(jj,i)
6782           jp=iabs(j)
6783           do kk=1,num_conti1
6784             j1=jcont_hb(kk,i1)
6785             jp1=iabs(j1)
6786 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6787 c     &         ' jj=',jj,' kk=',kk
6788 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6789             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6790      &          .or. j.lt.0 .and. j1.gt.0) .and.
6791      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6792 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6793 C The system gains extra energy.
6794               n_corr=n_corr+1
6795               sqd1=dsqrt(d_cont(jj,i))
6796               sqd2=dsqrt(d_cont(kk,i1))
6797               sred_geom = sqd1*sqd2
6798               IF (sred_geom.lt.cutoff_corr) THEN
6799                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6800      &            ekont,fprimcont)
6801 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6802 cd     &         ' jj=',jj,' kk=',kk
6803                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6804                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6805                 do l=1,3
6806                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6807                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6808                 enddo
6809                 n_corr1=n_corr1+1
6810 cd               write (iout,*) 'sred_geom=',sred_geom,
6811 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6812 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6813 cd               write (iout,*) "g_contij",g_contij
6814 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6815 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6816                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6817                 if (wcorr4.gt.0.0d0)
6818      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6819                   if (energy_dec.and.wcorr4.gt.0.0d0)
6820      1                 write (iout,'(a6,4i5,0pf7.3)')
6821      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6822 c                write (iout,*) "gradcorr5 before eello5"
6823 c                do iii=1,nres
6824 c                  write (iout,'(i5,3f10.5)')
6825 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6826 c                enddo
6827                 if (wcorr5.gt.0.0d0)
6828      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6829 c                write (iout,*) "gradcorr5 after eello5"
6830 c                do iii=1,nres
6831 c                  write (iout,'(i5,3f10.5)')
6832 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6833 c                enddo
6834                   if (energy_dec.and.wcorr5.gt.0.0d0)
6835      1                 write (iout,'(a6,4i5,0pf7.3)')
6836      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6837 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6838 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6839                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6840      &               .or. wturn6.eq.0.0d0))then
6841 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6842                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6843                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6844      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6845 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6846 cd     &            'ecorr6=',ecorr6
6847 cd                write (iout,'(4e15.5)') sred_geom,
6848 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6849 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6850 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6851                 else if (wturn6.gt.0.0d0
6852      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6853 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6854                   eturn6=eturn6+eello_turn6(i,jj,kk)
6855                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6856      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6857 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6858                 endif
6859               ENDIF
6860 1111          continue
6861             endif
6862           enddo ! kk
6863         enddo ! jj
6864       enddo ! i
6865       do i=1,nres
6866         num_cont_hb(i)=num_cont_hb_old(i)
6867       enddo
6868 c                write (iout,*) "gradcorr5 in eello5"
6869 c                do iii=1,nres
6870 c                  write (iout,'(i5,3f10.5)')
6871 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6872 c                enddo
6873       return
6874       end
6875 c------------------------------------------------------------------------------
6876       subroutine add_hb_contact_eello(ii,jj,itask)
6877       implicit real*8 (a-h,o-z)
6878       include "DIMENSIONS"
6879       include "COMMON.IOUNITS"
6880       integer max_cont
6881       integer max_dim
6882       parameter (max_cont=maxconts)
6883       parameter (max_dim=70)
6884       include "COMMON.CONTACTS"
6885       double precision zapas(max_dim,maxconts,max_fg_procs),
6886      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6887       common /przechowalnia/ zapas
6888       integer i,j,ii,jj,iproc,itask(4),nn
6889 c      write (iout,*) "itask",itask
6890       do i=1,2
6891         iproc=itask(i)
6892         if (iproc.gt.0) then
6893           do j=1,num_cont_hb(ii)
6894             jjc=jcont_hb(j,ii)
6895 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6896             if (jjc.eq.jj) then
6897               ncont_sent(iproc)=ncont_sent(iproc)+1
6898               nn=ncont_sent(iproc)
6899               zapas(1,nn,iproc)=ii
6900               zapas(2,nn,iproc)=jjc
6901               zapas(3,nn,iproc)=d_cont(j,ii)
6902               ind=3
6903               do kk=1,3
6904                 ind=ind+1
6905                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6906               enddo
6907               do kk=1,2
6908                 do ll=1,2
6909                   ind=ind+1
6910                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6911                 enddo
6912               enddo
6913               do jj=1,5
6914                 do kk=1,3
6915                   do ll=1,2
6916                     do mm=1,2
6917                       ind=ind+1
6918                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6919                     enddo
6920                   enddo
6921                 enddo
6922               enddo
6923               exit
6924             endif
6925           enddo
6926         endif
6927       enddo
6928       return
6929       end
6930 c------------------------------------------------------------------------------
6931       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6932       implicit real*8 (a-h,o-z)
6933       include 'DIMENSIONS'
6934       include 'COMMON.IOUNITS'
6935       include 'COMMON.DERIV'
6936       include 'COMMON.INTERACT'
6937       include 'COMMON.CONTACTS'
6938       double precision gx(3),gx1(3)
6939       logical lprn
6940       lprn=.false.
6941       eij=facont_hb(jj,i)
6942       ekl=facont_hb(kk,k)
6943       ees0pij=ees0p(jj,i)
6944       ees0pkl=ees0p(kk,k)
6945       ees0mij=ees0m(jj,i)
6946       ees0mkl=ees0m(kk,k)
6947       ekont=eij*ekl
6948       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6949 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6950 C Following 4 lines for diagnostics.
6951 cd    ees0pkl=0.0D0
6952 cd    ees0pij=1.0D0
6953 cd    ees0mkl=0.0D0
6954 cd    ees0mij=1.0D0
6955 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6956 c     & 'Contacts ',i,j,
6957 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6958 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6959 c     & 'gradcorr_long'
6960 C Calculate the multi-body contribution to energy.
6961 c      ecorr=ecorr+ekont*ees
6962 C Calculate multi-body contributions to the gradient.
6963       coeffpees0pij=coeffp*ees0pij
6964       coeffmees0mij=coeffm*ees0mij
6965       coeffpees0pkl=coeffp*ees0pkl
6966       coeffmees0mkl=coeffm*ees0mkl
6967       do ll=1,3
6968 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6969         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6970      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6971      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6972         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6973      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6974      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6975 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6976         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6977      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6978      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6979         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6980      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6981      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6982         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6983      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6984      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6985         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6986         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6987         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6988      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6989      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6990         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6991         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6992 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6993       enddo
6994 c      write (iout,*)
6995 cgrad      do m=i+1,j-1
6996 cgrad        do ll=1,3
6997 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6998 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6999 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7000 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7001 cgrad        enddo
7002 cgrad      enddo
7003 cgrad      do m=k+1,l-1
7004 cgrad        do ll=1,3
7005 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7006 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7007 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7008 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7009 cgrad        enddo
7010 cgrad      enddo
7011 c      write (iout,*) "ehbcorr",ekont*ees
7012       ehbcorr=ekont*ees
7013       return
7014       end
7015 #ifdef MOMENT
7016 C---------------------------------------------------------------------------
7017       subroutine dipole(i,j,jj)
7018       implicit real*8 (a-h,o-z)
7019       include 'DIMENSIONS'
7020       include 'COMMON.IOUNITS'
7021       include 'COMMON.CHAIN'
7022       include 'COMMON.FFIELD'
7023       include 'COMMON.DERIV'
7024       include 'COMMON.INTERACT'
7025       include 'COMMON.CONTACTS'
7026       include 'COMMON.TORSION'
7027       include 'COMMON.VAR'
7028       include 'COMMON.GEO'
7029       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7030      &  auxmat(2,2)
7031       iti1 = itortyp(itype(i+1))
7032       if (j.lt.nres-1) then
7033         itj1 = itortyp(itype(j+1))
7034       else
7035         itj1=ntortyp+1
7036       endif
7037       do iii=1,2
7038         dipi(iii,1)=Ub2(iii,i)
7039         dipderi(iii)=Ub2der(iii,i)
7040         dipi(iii,2)=b1(iii,i+1)
7041         dipj(iii,1)=Ub2(iii,j)
7042         dipderj(iii)=Ub2der(iii,j)
7043         dipj(iii,2)=b1(iii,j+1)
7044       enddo
7045       kkk=0
7046       do iii=1,2
7047         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7048         do jjj=1,2
7049           kkk=kkk+1
7050           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7051         enddo
7052       enddo
7053       do kkk=1,5
7054         do lll=1,3
7055           mmm=0
7056           do iii=1,2
7057             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7058      &        auxvec(1))
7059             do jjj=1,2
7060               mmm=mmm+1
7061               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7062             enddo
7063           enddo
7064         enddo
7065       enddo
7066       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7067       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7068       do iii=1,2
7069         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7070       enddo
7071       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7072       do iii=1,2
7073         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7074       enddo
7075       return
7076       end
7077 #endif
7078 C---------------------------------------------------------------------------
7079       subroutine calc_eello(i,j,k,l,jj,kk)
7080 C
7081 C This subroutine computes matrices and vectors needed to calculate
7082 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7083 C
7084       implicit real*8 (a-h,o-z)
7085       include 'DIMENSIONS'
7086       include 'COMMON.IOUNITS'
7087       include 'COMMON.CHAIN'
7088       include 'COMMON.DERIV'
7089       include 'COMMON.INTERACT'
7090       include 'COMMON.CONTACTS'
7091       include 'COMMON.TORSION'
7092       include 'COMMON.VAR'
7093       include 'COMMON.GEO'
7094       include 'COMMON.FFIELD'
7095       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7096      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7097       logical lprn
7098       common /kutas/ lprn
7099 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7100 cd     & ' jj=',jj,' kk=',kk
7101 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7102 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7103 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7104       do iii=1,2
7105         do jjj=1,2
7106           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7107           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7108         enddo
7109       enddo
7110       call transpose2(aa1(1,1),aa1t(1,1))
7111       call transpose2(aa2(1,1),aa2t(1,1))
7112       do kkk=1,5
7113         do lll=1,3
7114           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7115      &      aa1tder(1,1,lll,kkk))
7116           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7117      &      aa2tder(1,1,lll,kkk))
7118         enddo
7119       enddo
7120       if (l.eq.j+1) then
7121 C parallel orientation of the two CA-CA-CA frames.
7122         if (i.gt.1) then
7123           iti=itortyp(itype(i))
7124         else
7125           iti=ntortyp+1
7126         endif
7127         itk1=itortyp(itype(k+1))
7128         itj=itortyp(itype(j))
7129         if (l.lt.nres-1) then
7130           itl1=itortyp(itype(l+1))
7131         else
7132           itl1=ntortyp+1
7133         endif
7134 C A1 kernel(j+1) A2T
7135 cd        do iii=1,2
7136 cd          write (iout,'(3f10.5,5x,3f10.5)')
7137 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7138 cd        enddo
7139         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7140      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7141      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7142 C Following matrices are needed only for 6-th order cumulants
7143         IF (wcorr6.gt.0.0d0) THEN
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.,EUgC(1,1,l),EUgCder(1,1,l),
7146      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7147         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7148      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7149      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7150      &   ADtEAderx(1,1,1,1,1,1))
7151         lprn=.false.
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.,DtUg2EUg(1,1,l),
7154      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7155      &   ADtEA1derx(1,1,1,1,1,1))
7156         ENDIF
7157 C End 6-th order cumulants
7158 cd        lprn=.false.
7159 cd        if (lprn) then
7160 cd        write (2,*) 'In calc_eello6'
7161 cd        do iii=1,2
7162 cd          write (2,*) 'iii=',iii
7163 cd          do kkk=1,5
7164 cd            write (2,*) 'kkk=',kkk
7165 cd            do jjj=1,2
7166 cd              write (2,'(3(2f10.5),5x)')
7167 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7168 cd            enddo
7169 cd          enddo
7170 cd        enddo
7171 cd        endif
7172         call transpose2(EUgder(1,1,k),auxmat(1,1))
7173         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7174         call transpose2(EUg(1,1,k),auxmat(1,1))
7175         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7176         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7177         do iii=1,2
7178           do kkk=1,5
7179             do lll=1,3
7180               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7181      &          EAEAderx(1,1,lll,kkk,iii,1))
7182             enddo
7183           enddo
7184         enddo
7185 C A1T kernel(i+1) A2
7186         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7187      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7188      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7189 C Following matrices are needed only for 6-th order cumulants
7190         IF (wcorr6.gt.0.0d0) THEN
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.,EUgC(1,1,k),EUgCder(1,1,k),
7193      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7194         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7195      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7196      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7197      &   ADtEAderx(1,1,1,1,1,2))
7198         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7199      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7200      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7201      &   ADtEA1derx(1,1,1,1,1,2))
7202         ENDIF
7203 C End 6-th order cumulants
7204         call transpose2(EUgder(1,1,l),auxmat(1,1))
7205         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7206         call transpose2(EUg(1,1,l),auxmat(1,1))
7207         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7208         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7209         do iii=1,2
7210           do kkk=1,5
7211             do lll=1,3
7212               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7213      &          EAEAderx(1,1,lll,kkk,iii,2))
7214             enddo
7215           enddo
7216         enddo
7217 C AEAb1 and AEAb2
7218 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7219 C They are needed only when the fifth- or the sixth-order cumulants are
7220 C indluded.
7221         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7222         call transpose2(AEA(1,1,1),auxmat(1,1))
7223         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7224         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7225         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7226         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7227         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7228         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7229         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7230         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7231         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7232         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7233         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7234         call transpose2(AEA(1,1,2),auxmat(1,1))
7235         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7236         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7237         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7238         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7239         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7240         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7241         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7242         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7243         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7244         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7245         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7246 C Calculate the Cartesian derivatives of the vectors.
7247         do iii=1,2
7248           do kkk=1,5
7249             do lll=1,3
7250               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7251               call matvec2(auxmat(1,1),b1(1,i),
7252      &          AEAb1derx(1,lll,kkk,iii,1,1))
7253               call matvec2(auxmat(1,1),Ub2(1,i),
7254      &          AEAb2derx(1,lll,kkk,iii,1,1))
7255               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7256      &          AEAb1derx(1,lll,kkk,iii,2,1))
7257               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7258      &          AEAb2derx(1,lll,kkk,iii,2,1))
7259               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7260               call matvec2(auxmat(1,1),b1(1,j),
7261      &          AEAb1derx(1,lll,kkk,iii,1,2))
7262               call matvec2(auxmat(1,1),Ub2(1,j),
7263      &          AEAb2derx(1,lll,kkk,iii,1,2))
7264               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7265      &          AEAb1derx(1,lll,kkk,iii,2,2))
7266               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7267      &          AEAb2derx(1,lll,kkk,iii,2,2))
7268             enddo
7269           enddo
7270         enddo
7271         ENDIF
7272 C End vectors
7273       else
7274 C Antiparallel orientation of the two CA-CA-CA frames.
7275         if (i.gt.1) then
7276           iti=itortyp(itype(i))
7277         else
7278           iti=ntortyp+1
7279         endif
7280         itk1=itortyp(itype(k+1))
7281         itl=itortyp(itype(l))
7282         itj=itortyp(itype(j))
7283         if (j.lt.nres-1) then
7284           itj1=itortyp(itype(j+1))
7285         else
7286           itj1=ntortyp+1
7287         endif
7288 C A2 kernel(j-1)T A1T
7289         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7290      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7291      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7292 C Following matrices are needed only for 6-th order cumulants
7293         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7294      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7295         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7296      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7297      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7298         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7299      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7300      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7301      &   ADtEAderx(1,1,1,1,1,1))
7302         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7303      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7304      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7305      &   ADtEA1derx(1,1,1,1,1,1))
7306         ENDIF
7307 C End 6-th order cumulants
7308         call transpose2(EUgder(1,1,k),auxmat(1,1))
7309         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7310         call transpose2(EUg(1,1,k),auxmat(1,1))
7311         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7312         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7313         do iii=1,2
7314           do kkk=1,5
7315             do lll=1,3
7316               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7317      &          EAEAderx(1,1,lll,kkk,iii,1))
7318             enddo
7319           enddo
7320         enddo
7321 C A2T kernel(i+1)T A1
7322         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7323      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7324      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7325 C Following matrices are needed only for 6-th order cumulants
7326         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7327      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7328         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7329      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7330      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7331         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7332      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7333      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7334      &   ADtEAderx(1,1,1,1,1,2))
7335         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7336      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7337      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7338      &   ADtEA1derx(1,1,1,1,1,2))
7339         ENDIF
7340 C End 6-th order cumulants
7341         call transpose2(EUgder(1,1,j),auxmat(1,1))
7342         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7343         call transpose2(EUg(1,1,j),auxmat(1,1))
7344         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7345         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7346         do iii=1,2
7347           do kkk=1,5
7348             do lll=1,3
7349               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7350      &          EAEAderx(1,1,lll,kkk,iii,2))
7351             enddo
7352           enddo
7353         enddo
7354 C AEAb1 and AEAb2
7355 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7356 C They are needed only when the fifth- or the sixth-order cumulants are
7357 C indluded.
7358         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7359      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7360         call transpose2(AEA(1,1,1),auxmat(1,1))
7361         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7362         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7363         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7364         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7365         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7366         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7367         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7368         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7369         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7370         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7371         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7372         call transpose2(AEA(1,1,2),auxmat(1,1))
7373         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7374         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7375         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7376         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7377         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7378         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7379         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7380         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7381         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7382         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7383         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7384 C Calculate the Cartesian derivatives of the vectors.
7385         do iii=1,2
7386           do kkk=1,5
7387             do lll=1,3
7388               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7389               call matvec2(auxmat(1,1),b1(1,i),
7390      &          AEAb1derx(1,lll,kkk,iii,1,1))
7391               call matvec2(auxmat(1,1),Ub2(1,i),
7392      &          AEAb2derx(1,lll,kkk,iii,1,1))
7393               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7394      &          AEAb1derx(1,lll,kkk,iii,2,1))
7395               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7396      &          AEAb2derx(1,lll,kkk,iii,2,1))
7397               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7398               call matvec2(auxmat(1,1),b1(1,l),
7399      &          AEAb1derx(1,lll,kkk,iii,1,2))
7400               call matvec2(auxmat(1,1),Ub2(1,l),
7401      &          AEAb2derx(1,lll,kkk,iii,1,2))
7402               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7403      &          AEAb1derx(1,lll,kkk,iii,2,2))
7404               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7405      &          AEAb2derx(1,lll,kkk,iii,2,2))
7406             enddo
7407           enddo
7408         enddo
7409         ENDIF
7410 C End vectors
7411       endif
7412       return
7413       end
7414 C---------------------------------------------------------------------------
7415       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7416      &  KK,KKderg,AKA,AKAderg,AKAderx)
7417       implicit none
7418       integer nderg
7419       logical transp
7420       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7421      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7422      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7423       integer iii,kkk,lll
7424       integer jjj,mmm
7425       logical lprn
7426       common /kutas/ lprn
7427       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7428       do iii=1,nderg
7429         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7430      &    AKAderg(1,1,iii))
7431       enddo
7432 cd      if (lprn) write (2,*) 'In kernel'
7433       do kkk=1,5
7434 cd        if (lprn) write (2,*) 'kkk=',kkk
7435         do lll=1,3
7436           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7437      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7438 cd          if (lprn) then
7439 cd            write (2,*) 'lll=',lll
7440 cd            write (2,*) 'iii=1'
7441 cd            do jjj=1,2
7442 cd              write (2,'(3(2f10.5),5x)')
7443 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7444 cd            enddo
7445 cd          endif
7446           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7447      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7448 cd          if (lprn) then
7449 cd            write (2,*) 'lll=',lll
7450 cd            write (2,*) 'iii=2'
7451 cd            do jjj=1,2
7452 cd              write (2,'(3(2f10.5),5x)')
7453 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7454 cd            enddo
7455 cd          endif
7456         enddo
7457       enddo
7458       return
7459       end
7460 C---------------------------------------------------------------------------
7461       double precision function eello4(i,j,k,l,jj,kk)
7462       implicit real*8 (a-h,o-z)
7463       include 'DIMENSIONS'
7464       include 'COMMON.IOUNITS'
7465       include 'COMMON.CHAIN'
7466       include 'COMMON.DERIV'
7467       include 'COMMON.INTERACT'
7468       include 'COMMON.CONTACTS'
7469       include 'COMMON.TORSION'
7470       include 'COMMON.VAR'
7471       include 'COMMON.GEO'
7472       double precision pizda(2,2),ggg1(3),ggg2(3)
7473 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7474 cd        eello4=0.0d0
7475 cd        return
7476 cd      endif
7477 cd      print *,'eello4:',i,j,k,l,jj,kk
7478 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7479 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7480 cold      eij=facont_hb(jj,i)
7481 cold      ekl=facont_hb(kk,k)
7482 cold      ekont=eij*ekl
7483       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7484 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7485       gcorr_loc(k-1)=gcorr_loc(k-1)
7486      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7487       if (l.eq.j+1) then
7488         gcorr_loc(l-1)=gcorr_loc(l-1)
7489      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7490       else
7491         gcorr_loc(j-1)=gcorr_loc(j-1)
7492      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7493       endif
7494       do iii=1,2
7495         do kkk=1,5
7496           do lll=1,3
7497             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7498      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7499 cd            derx(lll,kkk,iii)=0.0d0
7500           enddo
7501         enddo
7502       enddo
7503 cd      gcorr_loc(l-1)=0.0d0
7504 cd      gcorr_loc(j-1)=0.0d0
7505 cd      gcorr_loc(k-1)=0.0d0
7506 cd      eel4=1.0d0
7507 cd      write (iout,*)'Contacts have occurred for peptide groups',
7508 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7509 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7510       if (j.lt.nres-1) then
7511         j1=j+1
7512         j2=j-1
7513       else
7514         j1=j-1
7515         j2=j-2
7516       endif
7517       if (l.lt.nres-1) then
7518         l1=l+1
7519         l2=l-1
7520       else
7521         l1=l-1
7522         l2=l-2
7523       endif
7524       do ll=1,3
7525 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7526 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7527         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7528         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7529 cgrad        ghalf=0.5d0*ggg1(ll)
7530         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7531         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7532         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7533         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7534         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7535         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7536 cgrad        ghalf=0.5d0*ggg2(ll)
7537         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7538         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7539         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7540         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7541         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7542         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7543       enddo
7544 cgrad      do m=i+1,j-1
7545 cgrad        do ll=1,3
7546 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7547 cgrad        enddo
7548 cgrad      enddo
7549 cgrad      do m=k+1,l-1
7550 cgrad        do ll=1,3
7551 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7552 cgrad        enddo
7553 cgrad      enddo
7554 cgrad      do m=i+2,j2
7555 cgrad        do ll=1,3
7556 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7557 cgrad        enddo
7558 cgrad      enddo
7559 cgrad      do m=k+2,l2
7560 cgrad        do ll=1,3
7561 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7562 cgrad        enddo
7563 cgrad      enddo
7564 cd      do iii=1,nres-3
7565 cd        write (2,*) iii,gcorr_loc(iii)
7566 cd      enddo
7567       eello4=ekont*eel4
7568 cd      write (2,*) 'ekont',ekont
7569 cd      write (iout,*) 'eello4',ekont*eel4
7570       return
7571       end
7572 C---------------------------------------------------------------------------
7573       double precision function eello5(i,j,k,l,jj,kk)
7574       implicit real*8 (a-h,o-z)
7575       include 'DIMENSIONS'
7576       include 'COMMON.IOUNITS'
7577       include 'COMMON.CHAIN'
7578       include 'COMMON.DERIV'
7579       include 'COMMON.INTERACT'
7580       include 'COMMON.CONTACTS'
7581       include 'COMMON.TORSION'
7582       include 'COMMON.VAR'
7583       include 'COMMON.GEO'
7584       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7585       double precision ggg1(3),ggg2(3)
7586 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7587 C                                                                              C
7588 C                            Parallel chains                                   C
7589 C                                                                              C
7590 C          o             o                   o             o                   C
7591 C         /l\           / \             \   / \           / \   /              C
7592 C        /   \         /   \             \ /   \         /   \ /               C
7593 C       j| o |l1       | o |              o| o |         | o |o                C
7594 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7595 C      \i/   \         /   \ /             /   \         /   \                 C
7596 C       o    k1             o                                                  C
7597 C         (I)          (II)                (III)          (IV)                 C
7598 C                                                                              C
7599 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7600 C                                                                              C
7601 C                            Antiparallel chains                               C
7602 C                                                                              C
7603 C          o             o                   o             o                   C
7604 C         /j\           / \             \   / \           / \   /              C
7605 C        /   \         /   \             \ /   \         /   \ /               C
7606 C      j1| o |l        | o |              o| o |         | o |o                C
7607 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7608 C      \i/   \         /   \ /             /   \         /   \                 C
7609 C       o     k1            o                                                  C
7610 C         (I)          (II)                (III)          (IV)                 C
7611 C                                                                              C
7612 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7613 C                                                                              C
7614 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7615 C                                                                              C
7616 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7617 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7618 cd        eello5=0.0d0
7619 cd        return
7620 cd      endif
7621 cd      write (iout,*)
7622 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7623 cd     &   ' and',k,l
7624       itk=itortyp(itype(k))
7625       itl=itortyp(itype(l))
7626       itj=itortyp(itype(j))
7627       eello5_1=0.0d0
7628       eello5_2=0.0d0
7629       eello5_3=0.0d0
7630       eello5_4=0.0d0
7631 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7632 cd     &   eel5_3_num,eel5_4_num)
7633       do iii=1,2
7634         do kkk=1,5
7635           do lll=1,3
7636             derx(lll,kkk,iii)=0.0d0
7637           enddo
7638         enddo
7639       enddo
7640 cd      eij=facont_hb(jj,i)
7641 cd      ekl=facont_hb(kk,k)
7642 cd      ekont=eij*ekl
7643 cd      write (iout,*)'Contacts have occurred for peptide groups',
7644 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7645 cd      goto 1111
7646 C Contribution from the graph I.
7647 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7648 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7649       call transpose2(EUg(1,1,k),auxmat(1,1))
7650       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7651       vv(1)=pizda(1,1)-pizda(2,2)
7652       vv(2)=pizda(1,2)+pizda(2,1)
7653       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7654      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7655 C Explicit gradient in virtual-dihedral angles.
7656       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7657      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7658      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7659       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7660       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7661       vv(1)=pizda(1,1)-pizda(2,2)
7662       vv(2)=pizda(1,2)+pizda(2,1)
7663       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7664      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7665      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7666       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7667       vv(1)=pizda(1,1)-pizda(2,2)
7668       vv(2)=pizda(1,2)+pizda(2,1)
7669       if (l.eq.j+1) then
7670         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7671      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7672      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7673       else
7674         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7675      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7676      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7677       endif
7678 C Cartesian gradient
7679       do iii=1,2
7680         do kkk=1,5
7681           do lll=1,3
7682             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7683      &        pizda(1,1))
7684             vv(1)=pizda(1,1)-pizda(2,2)
7685             vv(2)=pizda(1,2)+pizda(2,1)
7686             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7687      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7688      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7689           enddo
7690         enddo
7691       enddo
7692 c      goto 1112
7693 c1111  continue
7694 C Contribution from graph II
7695       call transpose2(EE(1,1,itk),auxmat(1,1))
7696       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7697       vv(1)=pizda(1,1)+pizda(2,2)
7698       vv(2)=pizda(2,1)-pizda(1,2)
7699       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7700      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7701 C Explicit gradient in virtual-dihedral angles.
7702       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7703      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7704       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7705       vv(1)=pizda(1,1)+pizda(2,2)
7706       vv(2)=pizda(2,1)-pizda(1,2)
7707       if (l.eq.j+1) then
7708         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7709      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7710      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7711       else
7712         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7713      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7714      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7715       endif
7716 C Cartesian gradient
7717       do iii=1,2
7718         do kkk=1,5
7719           do lll=1,3
7720             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7721      &        pizda(1,1))
7722             vv(1)=pizda(1,1)+pizda(2,2)
7723             vv(2)=pizda(2,1)-pizda(1,2)
7724             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7725      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7726      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7727           enddo
7728         enddo
7729       enddo
7730 cd      goto 1112
7731 cd1111  continue
7732       if (l.eq.j+1) then
7733 cd        goto 1110
7734 C Parallel orientation
7735 C Contribution from graph III
7736         call transpose2(EUg(1,1,l),auxmat(1,1))
7737         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7738         vv(1)=pizda(1,1)-pizda(2,2)
7739         vv(2)=pizda(1,2)+pizda(2,1)
7740         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7741      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7742 C Explicit gradient in virtual-dihedral angles.
7743         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7744      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7745      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7746         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7747         vv(1)=pizda(1,1)-pizda(2,2)
7748         vv(2)=pizda(1,2)+pizda(2,1)
7749         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7750      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7751      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7752         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7753         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7754         vv(1)=pizda(1,1)-pizda(2,2)
7755         vv(2)=pizda(1,2)+pizda(2,1)
7756         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7757      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7758      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7759 C Cartesian gradient
7760         do iii=1,2
7761           do kkk=1,5
7762             do lll=1,3
7763               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7764      &          pizda(1,1))
7765               vv(1)=pizda(1,1)-pizda(2,2)
7766               vv(2)=pizda(1,2)+pizda(2,1)
7767               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7768      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7769      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7770             enddo
7771           enddo
7772         enddo
7773 cd        goto 1112
7774 C Contribution from graph IV
7775 cd1110    continue
7776         call transpose2(EE(1,1,itl),auxmat(1,1))
7777         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7778         vv(1)=pizda(1,1)+pizda(2,2)
7779         vv(2)=pizda(2,1)-pizda(1,2)
7780         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7781      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7782 C Explicit gradient in virtual-dihedral angles.
7783         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7784      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7785         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7786         vv(1)=pizda(1,1)+pizda(2,2)
7787         vv(2)=pizda(2,1)-pizda(1,2)
7788         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7789      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7790      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7791 C Cartesian gradient
7792         do iii=1,2
7793           do kkk=1,5
7794             do lll=1,3
7795               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7796      &          pizda(1,1))
7797               vv(1)=pizda(1,1)+pizda(2,2)
7798               vv(2)=pizda(2,1)-pizda(1,2)
7799               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7800      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7801      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7802             enddo
7803           enddo
7804         enddo
7805       else
7806 C Antiparallel orientation
7807 C Contribution from graph III
7808 c        goto 1110
7809         call transpose2(EUg(1,1,j),auxmat(1,1))
7810         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7811         vv(1)=pizda(1,1)-pizda(2,2)
7812         vv(2)=pizda(1,2)+pizda(2,1)
7813         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7814      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7815 C Explicit gradient in virtual-dihedral angles.
7816         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7817      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7818      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7819         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7820         vv(1)=pizda(1,1)-pizda(2,2)
7821         vv(2)=pizda(1,2)+pizda(2,1)
7822         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7823      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7824      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7825         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7826         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7827         vv(1)=pizda(1,1)-pizda(2,2)
7828         vv(2)=pizda(1,2)+pizda(2,1)
7829         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7830      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7831      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7832 C Cartesian gradient
7833         do iii=1,2
7834           do kkk=1,5
7835             do lll=1,3
7836               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7837      &          pizda(1,1))
7838               vv(1)=pizda(1,1)-pizda(2,2)
7839               vv(2)=pizda(1,2)+pizda(2,1)
7840               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7841      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7842      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7843             enddo
7844           enddo
7845         enddo
7846 cd        goto 1112
7847 C Contribution from graph IV
7848 1110    continue
7849         call transpose2(EE(1,1,itj),auxmat(1,1))
7850         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7851         vv(1)=pizda(1,1)+pizda(2,2)
7852         vv(2)=pizda(2,1)-pizda(1,2)
7853         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7854      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7855 C Explicit gradient in virtual-dihedral angles.
7856         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7857      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7858         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7859         vv(1)=pizda(1,1)+pizda(2,2)
7860         vv(2)=pizda(2,1)-pizda(1,2)
7861         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7862      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7863      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7864 C Cartesian gradient
7865         do iii=1,2
7866           do kkk=1,5
7867             do lll=1,3
7868               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7869      &          pizda(1,1))
7870               vv(1)=pizda(1,1)+pizda(2,2)
7871               vv(2)=pizda(2,1)-pizda(1,2)
7872               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7873      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7874      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7875             enddo
7876           enddo
7877         enddo
7878       endif
7879 1112  continue
7880       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7881 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7882 cd        write (2,*) 'ijkl',i,j,k,l
7883 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7884 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7885 cd      endif
7886 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7887 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7888 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7889 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7890       if (j.lt.nres-1) then
7891         j1=j+1
7892         j2=j-1
7893       else
7894         j1=j-1
7895         j2=j-2
7896       endif
7897       if (l.lt.nres-1) then
7898         l1=l+1
7899         l2=l-1
7900       else
7901         l1=l-1
7902         l2=l-2
7903       endif
7904 cd      eij=1.0d0
7905 cd      ekl=1.0d0
7906 cd      ekont=1.0d0
7907 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7908 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7909 C        summed up outside the subrouine as for the other subroutines
7910 C        handling long-range interactions. The old code is commented out
7911 C        with "cgrad" to keep track of changes.
7912       do ll=1,3
7913 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7914 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7915         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7916         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7917 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7918 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7919 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7920 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7921 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7922 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7923 c     &   gradcorr5ij,
7924 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7925 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7926 cgrad        ghalf=0.5d0*ggg1(ll)
7927 cd        ghalf=0.0d0
7928         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7929         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7930         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7931         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7932         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7933         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7934 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7935 cgrad        ghalf=0.5d0*ggg2(ll)
7936 cd        ghalf=0.0d0
7937         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7938         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7939         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7940         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7941         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7942         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7943       enddo
7944 cd      goto 1112
7945 cgrad      do m=i+1,j-1
7946 cgrad        do ll=1,3
7947 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7948 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7949 cgrad        enddo
7950 cgrad      enddo
7951 cgrad      do m=k+1,l-1
7952 cgrad        do ll=1,3
7953 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7954 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7955 cgrad        enddo
7956 cgrad      enddo
7957 c1112  continue
7958 cgrad      do m=i+2,j2
7959 cgrad        do ll=1,3
7960 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7961 cgrad        enddo
7962 cgrad      enddo
7963 cgrad      do m=k+2,l2
7964 cgrad        do ll=1,3
7965 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7966 cgrad        enddo
7967 cgrad      enddo
7968 cd      do iii=1,nres-3
7969 cd        write (2,*) iii,g_corr5_loc(iii)
7970 cd      enddo
7971       eello5=ekont*eel5
7972 cd      write (2,*) 'ekont',ekont
7973 cd      write (iout,*) 'eello5',ekont*eel5
7974       return
7975       end
7976 c--------------------------------------------------------------------------
7977       double precision function eello6(i,j,k,l,jj,kk)
7978       implicit real*8 (a-h,o-z)
7979       include 'DIMENSIONS'
7980       include 'COMMON.IOUNITS'
7981       include 'COMMON.CHAIN'
7982       include 'COMMON.DERIV'
7983       include 'COMMON.INTERACT'
7984       include 'COMMON.CONTACTS'
7985       include 'COMMON.TORSION'
7986       include 'COMMON.VAR'
7987       include 'COMMON.GEO'
7988       include 'COMMON.FFIELD'
7989       double precision ggg1(3),ggg2(3)
7990 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7991 cd        eello6=0.0d0
7992 cd        return
7993 cd      endif
7994 cd      write (iout,*)
7995 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7996 cd     &   ' and',k,l
7997       eello6_1=0.0d0
7998       eello6_2=0.0d0
7999       eello6_3=0.0d0
8000       eello6_4=0.0d0
8001       eello6_5=0.0d0
8002       eello6_6=0.0d0
8003 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8004 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8005       do iii=1,2
8006         do kkk=1,5
8007           do lll=1,3
8008             derx(lll,kkk,iii)=0.0d0
8009           enddo
8010         enddo
8011       enddo
8012 cd      eij=facont_hb(jj,i)
8013 cd      ekl=facont_hb(kk,k)
8014 cd      ekont=eij*ekl
8015 cd      eij=1.0d0
8016 cd      ekl=1.0d0
8017 cd      ekont=1.0d0
8018       if (l.eq.j+1) then
8019         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8020         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8021         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8022         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8023         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8024         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8025       else
8026         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8027         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8028         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8029         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8030         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8031           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8032         else
8033           eello6_5=0.0d0
8034         endif
8035         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8036       endif
8037 C If turn contributions are considered, they will be handled separately.
8038       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8039 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8040 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8041 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8042 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8043 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8044 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8045 cd      goto 1112
8046       if (j.lt.nres-1) then
8047         j1=j+1
8048         j2=j-1
8049       else
8050         j1=j-1
8051         j2=j-2
8052       endif
8053       if (l.lt.nres-1) then
8054         l1=l+1
8055         l2=l-1
8056       else
8057         l1=l-1
8058         l2=l-2
8059       endif
8060       do ll=1,3
8061 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8062 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8063 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8064 cgrad        ghalf=0.5d0*ggg1(ll)
8065 cd        ghalf=0.0d0
8066         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8067         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8068         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8069         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8070         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8071         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8072         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8073         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8074 cgrad        ghalf=0.5d0*ggg2(ll)
8075 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8076 cd        ghalf=0.0d0
8077         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8078         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8079         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8080         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8081         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8082         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8083       enddo
8084 cd      goto 1112
8085 cgrad      do m=i+1,j-1
8086 cgrad        do ll=1,3
8087 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8088 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8089 cgrad        enddo
8090 cgrad      enddo
8091 cgrad      do m=k+1,l-1
8092 cgrad        do ll=1,3
8093 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8094 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8095 cgrad        enddo
8096 cgrad      enddo
8097 cgrad1112  continue
8098 cgrad      do m=i+2,j2
8099 cgrad        do ll=1,3
8100 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8101 cgrad        enddo
8102 cgrad      enddo
8103 cgrad      do m=k+2,l2
8104 cgrad        do ll=1,3
8105 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8106 cgrad        enddo
8107 cgrad      enddo
8108 cd      do iii=1,nres-3
8109 cd        write (2,*) iii,g_corr6_loc(iii)
8110 cd      enddo
8111       eello6=ekont*eel6
8112 cd      write (2,*) 'ekont',ekont
8113 cd      write (iout,*) 'eello6',ekont*eel6
8114       return
8115       end
8116 c--------------------------------------------------------------------------
8117       double precision function eello6_graph1(i,j,k,l,imat,swap)
8118       implicit real*8 (a-h,o-z)
8119       include 'DIMENSIONS'
8120       include 'COMMON.IOUNITS'
8121       include 'COMMON.CHAIN'
8122       include 'COMMON.DERIV'
8123       include 'COMMON.INTERACT'
8124       include 'COMMON.CONTACTS'
8125       include 'COMMON.TORSION'
8126       include 'COMMON.VAR'
8127       include 'COMMON.GEO'
8128       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8129       logical swap
8130       logical lprn
8131       common /kutas/ lprn
8132 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8133 C                                                                              C
8134 C      Parallel       Antiparallel                                             C
8135 C                                                                              C
8136 C          o             o                                                     C
8137 C         /l\           /j\                                                    C
8138 C        /   \         /   \                                                   C
8139 C       /| o |         | o |\                                                  C
8140 C     \ j|/k\|  /   \  |/k\|l /                                                C
8141 C      \ /   \ /     \ /   \ /                                                 C
8142 C       o     o       o     o                                                  C
8143 C       i             i                                                        C
8144 C                                                                              C
8145 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8146       itk=itortyp(itype(k))
8147       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8148       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8149       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8150       call transpose2(EUgC(1,1,k),auxmat(1,1))
8151       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8152       vv1(1)=pizda1(1,1)-pizda1(2,2)
8153       vv1(2)=pizda1(1,2)+pizda1(2,1)
8154       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8155       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8156       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8157       s5=scalar2(vv(1),Dtobr2(1,i))
8158 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8159       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8160       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8161      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8162      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8163      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8164      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8165      & +scalar2(vv(1),Dtobr2der(1,i)))
8166       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8167       vv1(1)=pizda1(1,1)-pizda1(2,2)
8168       vv1(2)=pizda1(1,2)+pizda1(2,1)
8169       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8170       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8171       if (l.eq.j+1) then
8172         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8173      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8174      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8175      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8176      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8177       else
8178         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8179      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8180      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8181      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8182      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8183       endif
8184       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8185       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8186       vv1(1)=pizda1(1,1)-pizda1(2,2)
8187       vv1(2)=pizda1(1,2)+pizda1(2,1)
8188       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8189      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8190      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8191      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8192       do iii=1,2
8193         if (swap) then
8194           ind=3-iii
8195         else
8196           ind=iii
8197         endif
8198         do kkk=1,5
8199           do lll=1,3
8200             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8201             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8202             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8203             call transpose2(EUgC(1,1,k),auxmat(1,1))
8204             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8205      &        pizda1(1,1))
8206             vv1(1)=pizda1(1,1)-pizda1(2,2)
8207             vv1(2)=pizda1(1,2)+pizda1(2,1)
8208             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8209             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8210      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8211             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8212      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8213             s5=scalar2(vv(1),Dtobr2(1,i))
8214             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8215           enddo
8216         enddo
8217       enddo
8218       return
8219       end
8220 c----------------------------------------------------------------------------
8221       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8222       implicit real*8 (a-h,o-z)
8223       include 'DIMENSIONS'
8224       include 'COMMON.IOUNITS'
8225       include 'COMMON.CHAIN'
8226       include 'COMMON.DERIV'
8227       include 'COMMON.INTERACT'
8228       include 'COMMON.CONTACTS'
8229       include 'COMMON.TORSION'
8230       include 'COMMON.VAR'
8231       include 'COMMON.GEO'
8232       logical swap
8233       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8234      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8235       logical lprn
8236       common /kutas/ lprn
8237 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8238 C                                                                              C
8239 C      Parallel       Antiparallel                                             C
8240 C                                                                              C
8241 C          o             o                                                     C
8242 C     \   /l\           /j\   /                                                C
8243 C      \ /   \         /   \ /                                                 C
8244 C       o| o |         | o |o                                                  C
8245 C     \ j|/k\|      \  |/k\|l                                                  C
8246 C      \ /   \       \ /   \                                                   C
8247 C       o             o                                                        C
8248 C       i             i                                                        C
8249 C                                                                              C
8250 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8251 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8252 C AL 7/4/01 s1 would occur in the sixth-order moment,
8253 C           but not in a cluster cumulant
8254 #ifdef MOMENT
8255       s1=dip(1,jj,i)*dip(1,kk,k)
8256 #endif
8257       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8258       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8259       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8260       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8261       call transpose2(EUg(1,1,k),auxmat(1,1))
8262       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8263       vv(1)=pizda(1,1)-pizda(2,2)
8264       vv(2)=pizda(1,2)+pizda(2,1)
8265       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8266 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8267 #ifdef MOMENT
8268       eello6_graph2=-(s1+s2+s3+s4)
8269 #else
8270       eello6_graph2=-(s2+s3+s4)
8271 #endif
8272 c      eello6_graph2=-s3
8273 C Derivatives in gamma(i-1)
8274       if (i.gt.1) then
8275 #ifdef MOMENT
8276         s1=dipderg(1,jj,i)*dip(1,kk,k)
8277 #endif
8278         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8279         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8280         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8281         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8282 #ifdef MOMENT
8283         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8284 #else
8285         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8286 #endif
8287 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8288       endif
8289 C Derivatives in gamma(k-1)
8290 #ifdef MOMENT
8291       s1=dip(1,jj,i)*dipderg(1,kk,k)
8292 #endif
8293       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8294       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8295       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8296       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8297       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8298       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8299       vv(1)=pizda(1,1)-pizda(2,2)
8300       vv(2)=pizda(1,2)+pizda(2,1)
8301       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8302 #ifdef MOMENT
8303       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8304 #else
8305       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8306 #endif
8307 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8308 C Derivatives in gamma(j-1) or gamma(l-1)
8309       if (j.gt.1) then
8310 #ifdef MOMENT
8311         s1=dipderg(3,jj,i)*dip(1,kk,k)
8312 #endif
8313         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8314         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8315         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8316         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8317         vv(1)=pizda(1,1)-pizda(2,2)
8318         vv(2)=pizda(1,2)+pizda(2,1)
8319         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8320 #ifdef MOMENT
8321         if (swap) then
8322           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8323         else
8324           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8325         endif
8326 #endif
8327         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8328 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8329       endif
8330 C Derivatives in gamma(l-1) or gamma(j-1)
8331       if (l.gt.1) then
8332 #ifdef MOMENT
8333         s1=dip(1,jj,i)*dipderg(3,kk,k)
8334 #endif
8335         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8336         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8337         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8338         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8339         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8340         vv(1)=pizda(1,1)-pizda(2,2)
8341         vv(2)=pizda(1,2)+pizda(2,1)
8342         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8343 #ifdef MOMENT
8344         if (swap) then
8345           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8346         else
8347           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8348         endif
8349 #endif
8350         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8351 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8352       endif
8353 C Cartesian derivatives.
8354       if (lprn) then
8355         write (2,*) 'In eello6_graph2'
8356         do iii=1,2
8357           write (2,*) 'iii=',iii
8358           do kkk=1,5
8359             write (2,*) 'kkk=',kkk
8360             do jjj=1,2
8361               write (2,'(3(2f10.5),5x)')
8362      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8363             enddo
8364           enddo
8365         enddo
8366       endif
8367       do iii=1,2
8368         do kkk=1,5
8369           do lll=1,3
8370 #ifdef MOMENT
8371             if (iii.eq.1) then
8372               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8373             else
8374               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8375             endif
8376 #endif
8377             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8378      &        auxvec(1))
8379             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8380             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8381      &        auxvec(1))
8382             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8383             call transpose2(EUg(1,1,k),auxmat(1,1))
8384             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8385      &        pizda(1,1))
8386             vv(1)=pizda(1,1)-pizda(2,2)
8387             vv(2)=pizda(1,2)+pizda(2,1)
8388             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8389 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8390 #ifdef MOMENT
8391             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8392 #else
8393             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8394 #endif
8395             if (swap) then
8396               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8397             else
8398               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8399             endif
8400           enddo
8401         enddo
8402       enddo
8403       return
8404       end
8405 c----------------------------------------------------------------------------
8406       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8407       implicit real*8 (a-h,o-z)
8408       include 'DIMENSIONS'
8409       include 'COMMON.IOUNITS'
8410       include 'COMMON.CHAIN'
8411       include 'COMMON.DERIV'
8412       include 'COMMON.INTERACT'
8413       include 'COMMON.CONTACTS'
8414       include 'COMMON.TORSION'
8415       include 'COMMON.VAR'
8416       include 'COMMON.GEO'
8417       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8418       logical swap
8419 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8420 C                                                                              C
8421 C      Parallel       Antiparallel                                             C
8422 C                                                                              C
8423 C          o             o                                                     C
8424 C         /l\   /   \   /j\                                                    C
8425 C        /   \ /     \ /   \                                                   C
8426 C       /| o |o       o| o |\                                                  C
8427 C       j|/k\|  /      |/k\|l /                                                C
8428 C        /   \ /       /   \ /                                                 C
8429 C       /     o       /     o                                                  C
8430 C       i             i                                                        C
8431 C                                                                              C
8432 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8433 C
8434 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8435 C           energy moment and not to the cluster cumulant.
8436       iti=itortyp(itype(i))
8437       if (j.lt.nres-1) then
8438         itj1=itortyp(itype(j+1))
8439       else
8440         itj1=ntortyp+1
8441       endif
8442       itk=itortyp(itype(k))
8443       itk1=itortyp(itype(k+1))
8444       if (l.lt.nres-1) then
8445         itl1=itortyp(itype(l+1))
8446       else
8447         itl1=ntortyp+1
8448       endif
8449 #ifdef MOMENT
8450       s1=dip(4,jj,i)*dip(4,kk,k)
8451 #endif
8452       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8453       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8454       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8455       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8456       call transpose2(EE(1,1,itk),auxmat(1,1))
8457       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8458       vv(1)=pizda(1,1)+pizda(2,2)
8459       vv(2)=pizda(2,1)-pizda(1,2)
8460       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8461 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8462 cd     & "sum",-(s2+s3+s4)
8463 #ifdef MOMENT
8464       eello6_graph3=-(s1+s2+s3+s4)
8465 #else
8466       eello6_graph3=-(s2+s3+s4)
8467 #endif
8468 c      eello6_graph3=-s4
8469 C Derivatives in gamma(k-1)
8470       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8471       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8472       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8473       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8474 C Derivatives in gamma(l-1)
8475       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8476       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8477       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8478       vv(1)=pizda(1,1)+pizda(2,2)
8479       vv(2)=pizda(2,1)-pizda(1,2)
8480       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8481       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8482 C Cartesian derivatives.
8483       do iii=1,2
8484         do kkk=1,5
8485           do lll=1,3
8486 #ifdef MOMENT
8487             if (iii.eq.1) then
8488               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8489             else
8490               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8491             endif
8492 #endif
8493             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8494      &        auxvec(1))
8495             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8496             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8497      &        auxvec(1))
8498             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8499             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8500      &        pizda(1,1))
8501             vv(1)=pizda(1,1)+pizda(2,2)
8502             vv(2)=pizda(2,1)-pizda(1,2)
8503             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8504 #ifdef MOMENT
8505             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8506 #else
8507             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8508 #endif
8509             if (swap) then
8510               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8511             else
8512               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8513             endif
8514 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8515           enddo
8516         enddo
8517       enddo
8518       return
8519       end
8520 c----------------------------------------------------------------------------
8521       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8522       implicit real*8 (a-h,o-z)
8523       include 'DIMENSIONS'
8524       include 'COMMON.IOUNITS'
8525       include 'COMMON.CHAIN'
8526       include 'COMMON.DERIV'
8527       include 'COMMON.INTERACT'
8528       include 'COMMON.CONTACTS'
8529       include 'COMMON.TORSION'
8530       include 'COMMON.VAR'
8531       include 'COMMON.GEO'
8532       include 'COMMON.FFIELD'
8533       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8534      & auxvec1(2),auxmat1(2,2)
8535       logical swap
8536 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8537 C                                                                              C
8538 C      Parallel       Antiparallel                                             C
8539 C                                                                              C
8540 C          o             o                                                     C
8541 C         /l\   /   \   /j\                                                    C
8542 C        /   \ /     \ /   \                                                   C
8543 C       /| o |o       o| o |\                                                  C
8544 C     \ j|/k\|      \  |/k\|l                                                  C
8545 C      \ /   \       \ /   \                                                   C
8546 C       o     \       o     \                                                  C
8547 C       i             i                                                        C
8548 C                                                                              C
8549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8550 C
8551 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8552 C           energy moment and not to the cluster cumulant.
8553 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8554       iti=itortyp(itype(i))
8555       itj=itortyp(itype(j))
8556       if (j.lt.nres-1) then
8557         itj1=itortyp(itype(j+1))
8558       else
8559         itj1=ntortyp+1
8560       endif
8561       itk=itortyp(itype(k))
8562       if (k.lt.nres-1) then
8563         itk1=itortyp(itype(k+1))
8564       else
8565         itk1=ntortyp+1
8566       endif
8567       itl=itortyp(itype(l))
8568       if (l.lt.nres-1) then
8569         itl1=itortyp(itype(l+1))
8570       else
8571         itl1=ntortyp+1
8572       endif
8573 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8574 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8575 cd     & ' itl',itl,' itl1',itl1
8576 #ifdef MOMENT
8577       if (imat.eq.1) then
8578         s1=dip(3,jj,i)*dip(3,kk,k)
8579       else
8580         s1=dip(2,jj,j)*dip(2,kk,l)
8581       endif
8582 #endif
8583       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8584       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8585       if (j.eq.l+1) then
8586         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8587         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8588       else
8589         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8590         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8591       endif
8592       call transpose2(EUg(1,1,k),auxmat(1,1))
8593       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8594       vv(1)=pizda(1,1)-pizda(2,2)
8595       vv(2)=pizda(2,1)+pizda(1,2)
8596       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8597 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8598 #ifdef MOMENT
8599       eello6_graph4=-(s1+s2+s3+s4)
8600 #else
8601       eello6_graph4=-(s2+s3+s4)
8602 #endif
8603 C Derivatives in gamma(i-1)
8604       if (i.gt.1) then
8605 #ifdef MOMENT
8606         if (imat.eq.1) then
8607           s1=dipderg(2,jj,i)*dip(3,kk,k)
8608         else
8609           s1=dipderg(4,jj,j)*dip(2,kk,l)
8610         endif
8611 #endif
8612         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8613         if (j.eq.l+1) then
8614           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8615           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8616         else
8617           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8618           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8619         endif
8620         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8621         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8622 cd          write (2,*) 'turn6 derivatives'
8623 #ifdef MOMENT
8624           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8625 #else
8626           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8627 #endif
8628         else
8629 #ifdef MOMENT
8630           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8631 #else
8632           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8633 #endif
8634         endif
8635       endif
8636 C Derivatives in gamma(k-1)
8637 #ifdef MOMENT
8638       if (imat.eq.1) then
8639         s1=dip(3,jj,i)*dipderg(2,kk,k)
8640       else
8641         s1=dip(2,jj,j)*dipderg(4,kk,l)
8642       endif
8643 #endif
8644       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8645       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8646       if (j.eq.l+1) then
8647         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8648         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8649       else
8650         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8651         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8652       endif
8653       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8654       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8655       vv(1)=pizda(1,1)-pizda(2,2)
8656       vv(2)=pizda(2,1)+pizda(1,2)
8657       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8658       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8659 #ifdef MOMENT
8660         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8661 #else
8662         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8663 #endif
8664       else
8665 #ifdef MOMENT
8666         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8667 #else
8668         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8669 #endif
8670       endif
8671 C Derivatives in gamma(j-1) or gamma(l-1)
8672       if (l.eq.j+1 .and. l.gt.1) then
8673         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8674         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8675         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8676         vv(1)=pizda(1,1)-pizda(2,2)
8677         vv(2)=pizda(2,1)+pizda(1,2)
8678         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8679         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8680       else if (j.gt.1) then
8681         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8682         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8683         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8684         vv(1)=pizda(1,1)-pizda(2,2)
8685         vv(2)=pizda(2,1)+pizda(1,2)
8686         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8687         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8688           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8689         else
8690           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8691         endif
8692       endif
8693 C Cartesian derivatives.
8694       do iii=1,2
8695         do kkk=1,5
8696           do lll=1,3
8697 #ifdef MOMENT
8698             if (iii.eq.1) then
8699               if (imat.eq.1) then
8700                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8701               else
8702                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8703               endif
8704             else
8705               if (imat.eq.1) then
8706                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8707               else
8708                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8709               endif
8710             endif
8711 #endif
8712             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8713      &        auxvec(1))
8714             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8715             if (j.eq.l+1) then
8716               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8717      &          b1(1,j+1),auxvec(1))
8718               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8719             else
8720               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8721      &          b1(1,l+1),auxvec(1))
8722               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8723             endif
8724             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8725      &        pizda(1,1))
8726             vv(1)=pizda(1,1)-pizda(2,2)
8727             vv(2)=pizda(2,1)+pizda(1,2)
8728             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8729             if (swap) then
8730               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8731 #ifdef MOMENT
8732                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8733      &             -(s1+s2+s4)
8734 #else
8735                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8736      &             -(s2+s4)
8737 #endif
8738                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8739               else
8740 #ifdef MOMENT
8741                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8742 #else
8743                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8744 #endif
8745                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8746               endif
8747             else
8748 #ifdef MOMENT
8749               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8750 #else
8751               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8752 #endif
8753               if (l.eq.j+1) then
8754                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8755               else
8756                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8757               endif
8758             endif
8759           enddo
8760         enddo
8761       enddo
8762       return
8763       end
8764 c----------------------------------------------------------------------------
8765       double precision function eello_turn6(i,jj,kk)
8766       implicit real*8 (a-h,o-z)
8767       include 'DIMENSIONS'
8768       include 'COMMON.IOUNITS'
8769       include 'COMMON.CHAIN'
8770       include 'COMMON.DERIV'
8771       include 'COMMON.INTERACT'
8772       include 'COMMON.CONTACTS'
8773       include 'COMMON.TORSION'
8774       include 'COMMON.VAR'
8775       include 'COMMON.GEO'
8776       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8777      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8778      &  ggg1(3),ggg2(3)
8779       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8780      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8781 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8782 C           the respective energy moment and not to the cluster cumulant.
8783       s1=0.0d0
8784       s8=0.0d0
8785       s13=0.0d0
8786 c
8787       eello_turn6=0.0d0
8788       j=i+4
8789       k=i+1
8790       l=i+3
8791       iti=itortyp(itype(i))
8792       itk=itortyp(itype(k))
8793       itk1=itortyp(itype(k+1))
8794       itl=itortyp(itype(l))
8795       itj=itortyp(itype(j))
8796 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8797 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8798 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8799 cd        eello6=0.0d0
8800 cd        return
8801 cd      endif
8802 cd      write (iout,*)
8803 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8804 cd     &   ' and',k,l
8805 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8806       do iii=1,2
8807         do kkk=1,5
8808           do lll=1,3
8809             derx_turn(lll,kkk,iii)=0.0d0
8810           enddo
8811         enddo
8812       enddo
8813 cd      eij=1.0d0
8814 cd      ekl=1.0d0
8815 cd      ekont=1.0d0
8816       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8817 cd      eello6_5=0.0d0
8818 cd      write (2,*) 'eello6_5',eello6_5
8819 #ifdef MOMENT
8820       call transpose2(AEA(1,1,1),auxmat(1,1))
8821       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8822       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8823       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8824 #endif
8825       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8826       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8827       s2 = scalar2(b1(1,k),vtemp1(1))
8828 #ifdef MOMENT
8829       call transpose2(AEA(1,1,2),atemp(1,1))
8830       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8831       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8832       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8833 #endif
8834       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8835       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8836       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8837 #ifdef MOMENT
8838       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8839       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8840       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8841       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8842       ss13 = scalar2(b1(1,k),vtemp4(1))
8843       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8844 #endif
8845 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8846 c      s1=0.0d0
8847 c      s2=0.0d0
8848 c      s8=0.0d0
8849 c      s12=0.0d0
8850 c      s13=0.0d0
8851       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8852 C Derivatives in gamma(i+2)
8853       s1d =0.0d0
8854       s8d =0.0d0
8855 #ifdef MOMENT
8856       call transpose2(AEA(1,1,1),auxmatd(1,1))
8857       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8858       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8859       call transpose2(AEAderg(1,1,2),atempd(1,1))
8860       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8861       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8862 #endif
8863       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8864       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8865       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8866 c      s1d=0.0d0
8867 c      s2d=0.0d0
8868 c      s8d=0.0d0
8869 c      s12d=0.0d0
8870 c      s13d=0.0d0
8871       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8872 C Derivatives in gamma(i+3)
8873 #ifdef MOMENT
8874       call transpose2(AEA(1,1,1),auxmatd(1,1))
8875       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8876       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8877       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8878 #endif
8879       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8880       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8881       s2d = scalar2(b1(1,k),vtemp1d(1))
8882 #ifdef MOMENT
8883       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8884       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8885 #endif
8886       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8887 #ifdef MOMENT
8888       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8889       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8890       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8891 #endif
8892 c      s1d=0.0d0
8893 c      s2d=0.0d0
8894 c      s8d=0.0d0
8895 c      s12d=0.0d0
8896 c      s13d=0.0d0
8897 #ifdef MOMENT
8898       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8899      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8900 #else
8901       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8902      &               -0.5d0*ekont*(s2d+s12d)
8903 #endif
8904 C Derivatives in gamma(i+4)
8905       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8906       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8907       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8908 #ifdef MOMENT
8909       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8910       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8911       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8912 #endif
8913 c      s1d=0.0d0
8914 c      s2d=0.0d0
8915 c      s8d=0.0d0
8916 C      s12d=0.0d0
8917 c      s13d=0.0d0
8918 #ifdef MOMENT
8919       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8920 #else
8921       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8922 #endif
8923 C Derivatives in gamma(i+5)
8924 #ifdef MOMENT
8925       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8926       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8927       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8928 #endif
8929       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8930       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8931       s2d = scalar2(b1(1,k),vtemp1d(1))
8932 #ifdef MOMENT
8933       call transpose2(AEA(1,1,2),atempd(1,1))
8934       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8935       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8936 #endif
8937       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8938       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8939 #ifdef MOMENT
8940       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8941       ss13d = scalar2(b1(1,k),vtemp4d(1))
8942       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8943 #endif
8944 c      s1d=0.0d0
8945 c      s2d=0.0d0
8946 c      s8d=0.0d0
8947 c      s12d=0.0d0
8948 c      s13d=0.0d0
8949 #ifdef MOMENT
8950       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8951      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8952 #else
8953       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8954      &               -0.5d0*ekont*(s2d+s12d)
8955 #endif
8956 C Cartesian derivatives
8957       do iii=1,2
8958         do kkk=1,5
8959           do lll=1,3
8960 #ifdef MOMENT
8961             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8962             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8963             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8964 #endif
8965             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8966             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8967      &          vtemp1d(1))
8968             s2d = scalar2(b1(1,k),vtemp1d(1))
8969 #ifdef MOMENT
8970             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8971             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8972             s8d = -(atempd(1,1)+atempd(2,2))*
8973      &           scalar2(cc(1,1,itl),vtemp2(1))
8974 #endif
8975             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8976      &           auxmatd(1,1))
8977             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8978             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8979 c      s1d=0.0d0
8980 c      s2d=0.0d0
8981 c      s8d=0.0d0
8982 c      s12d=0.0d0
8983 c      s13d=0.0d0
8984 #ifdef MOMENT
8985             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8986      &        - 0.5d0*(s1d+s2d)
8987 #else
8988             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8989      &        - 0.5d0*s2d
8990 #endif
8991 #ifdef MOMENT
8992             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8993      &        - 0.5d0*(s8d+s12d)
8994 #else
8995             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8996      &        - 0.5d0*s12d
8997 #endif
8998           enddo
8999         enddo
9000       enddo
9001 #ifdef MOMENT
9002       do kkk=1,5
9003         do lll=1,3
9004           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9005      &      achuj_tempd(1,1))
9006           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9007           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9008           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9009           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9010           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9011      &      vtemp4d(1))
9012           ss13d = scalar2(b1(1,k),vtemp4d(1))
9013           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9014           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9015         enddo
9016       enddo
9017 #endif
9018 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9019 cd     &  16*eel_turn6_num
9020 cd      goto 1112
9021       if (j.lt.nres-1) then
9022         j1=j+1
9023         j2=j-1
9024       else
9025         j1=j-1
9026         j2=j-2
9027       endif
9028       if (l.lt.nres-1) then
9029         l1=l+1
9030         l2=l-1
9031       else
9032         l1=l-1
9033         l2=l-2
9034       endif
9035       do ll=1,3
9036 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9037 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9038 cgrad        ghalf=0.5d0*ggg1(ll)
9039 cd        ghalf=0.0d0
9040         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9041         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9042         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9043      &    +ekont*derx_turn(ll,2,1)
9044         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9045         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9046      &    +ekont*derx_turn(ll,4,1)
9047         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9048         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9049         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9050 cgrad        ghalf=0.5d0*ggg2(ll)
9051 cd        ghalf=0.0d0
9052         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9053      &    +ekont*derx_turn(ll,2,2)
9054         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9055         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9056      &    +ekont*derx_turn(ll,4,2)
9057         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9058         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9059         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9060       enddo
9061 cd      goto 1112
9062 cgrad      do m=i+1,j-1
9063 cgrad        do ll=1,3
9064 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9065 cgrad        enddo
9066 cgrad      enddo
9067 cgrad      do m=k+1,l-1
9068 cgrad        do ll=1,3
9069 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9070 cgrad        enddo
9071 cgrad      enddo
9072 cgrad1112  continue
9073 cgrad      do m=i+2,j2
9074 cgrad        do ll=1,3
9075 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9076 cgrad        enddo
9077 cgrad      enddo
9078 cgrad      do m=k+2,l2
9079 cgrad        do ll=1,3
9080 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9081 cgrad        enddo
9082 cgrad      enddo
9083 cd      do iii=1,nres-3
9084 cd        write (2,*) iii,g_corr6_loc(iii)
9085 cd      enddo
9086       eello_turn6=ekont*eel_turn6
9087 cd      write (2,*) 'ekont',ekont
9088 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9089       return
9090       end
9091
9092 C-----------------------------------------------------------------------------
9093       double precision function scalar(u,v)
9094 !DIR$ INLINEALWAYS scalar
9095 #ifndef OSF
9096 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9097 #endif
9098       implicit none
9099       double precision u(3),v(3)
9100 cd      double precision sc
9101 cd      integer i
9102 cd      sc=0.0d0
9103 cd      do i=1,3
9104 cd        sc=sc+u(i)*v(i)
9105 cd      enddo
9106 cd      scalar=sc
9107
9108       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9109       return
9110       end
9111 crc-------------------------------------------------
9112       SUBROUTINE MATVEC2(A1,V1,V2)
9113 !DIR$ INLINEALWAYS MATVEC2
9114 #ifndef OSF
9115 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9116 #endif
9117       implicit real*8 (a-h,o-z)
9118       include 'DIMENSIONS'
9119       DIMENSION A1(2,2),V1(2),V2(2)
9120 c      DO 1 I=1,2
9121 c        VI=0.0
9122 c        DO 3 K=1,2
9123 c    3     VI=VI+A1(I,K)*V1(K)
9124 c        Vaux(I)=VI
9125 c    1 CONTINUE
9126
9127       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9128       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9129
9130       v2(1)=vaux1
9131       v2(2)=vaux2
9132       END
9133 C---------------------------------------
9134       SUBROUTINE MATMAT2(A1,A2,A3)
9135 #ifndef OSF
9136 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9137 #endif
9138       implicit real*8 (a-h,o-z)
9139       include 'DIMENSIONS'
9140       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9141 c      DIMENSION AI3(2,2)
9142 c        DO  J=1,2
9143 c          A3IJ=0.0
9144 c          DO K=1,2
9145 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9146 c          enddo
9147 c          A3(I,J)=A3IJ
9148 c       enddo
9149 c      enddo
9150
9151       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9152       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9153       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9154       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9155
9156       A3(1,1)=AI3_11
9157       A3(2,1)=AI3_21
9158       A3(1,2)=AI3_12
9159       A3(2,2)=AI3_22
9160       END
9161
9162 c-------------------------------------------------------------------------
9163       double precision function scalar2(u,v)
9164 !DIR$ INLINEALWAYS scalar2
9165       implicit none
9166       double precision u(2),v(2)
9167       double precision sc
9168       integer i
9169       scalar2=u(1)*v(1)+u(2)*v(2)
9170       return
9171       end
9172
9173 C-----------------------------------------------------------------------------
9174
9175       subroutine transpose2(a,at)
9176 !DIR$ INLINEALWAYS transpose2
9177 #ifndef OSF
9178 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9179 #endif
9180       implicit none
9181       double precision a(2,2),at(2,2)
9182       at(1,1)=a(1,1)
9183       at(1,2)=a(2,1)
9184       at(2,1)=a(1,2)
9185       at(2,2)=a(2,2)
9186       return
9187       end
9188 c--------------------------------------------------------------------------
9189       subroutine transpose(n,a,at)
9190       implicit none
9191       integer n,i,j
9192       double precision a(n,n),at(n,n)
9193       do i=1,n
9194         do j=1,n
9195           at(j,i)=a(i,j)
9196         enddo
9197       enddo
9198       return
9199       end
9200 C---------------------------------------------------------------------------
9201       subroutine prodmat3(a1,a2,kk,transp,prod)
9202 !DIR$ INLINEALWAYS prodmat3
9203 #ifndef OSF
9204 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9205 #endif
9206       implicit none
9207       integer i,j
9208       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9209       logical transp
9210 crc      double precision auxmat(2,2),prod_(2,2)
9211
9212       if (transp) then
9213 crc        call transpose2(kk(1,1),auxmat(1,1))
9214 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9215 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9216
9217            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9218      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9219            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9220      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9221            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9222      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9223            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9224      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9225
9226       else
9227 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9228 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9229
9230            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9231      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9232            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9233      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9234            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9235      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9236            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9237      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9238
9239       endif
9240 c      call transpose2(a2(1,1),a2t(1,1))
9241
9242 crc      print *,transp
9243 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9244 crc      print *,((prod(i,j),i=1,2),j=1,2)
9245
9246       return
9247       end
9248