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

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       evdw=0.0D0
1417 ccccc      energy_dec=.false.
1418 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       lprn=.false.
1421 c     if (icall.eq.0) lprn=.false.
1422       ind=0
1423       do i=iatsc_s,iatsc_e
1424         itypi=iabs(itype(i))
1425         if (itypi.eq.ntyp1) cycle
1426         itypi1=iabs(itype(i+1))
1427         xi=c(1,nres+i)
1428         yi=c(2,nres+i)
1429         zi=c(3,nres+i)
1430         dxi=dc_norm(1,nres+i)
1431         dyi=dc_norm(2,nres+i)
1432         dzi=dc_norm(3,nres+i)
1433 c        dsci_inv=dsc_inv(itypi)
1434         dsci_inv=vbld_inv(i+nres)
1435 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1436 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1437 C
1438 C Calculate SC interaction energy.
1439 C
1440         do iint=1,nint_gr(i)
1441           do j=istart(i,iint),iend(i,iint)
1442             ind=ind+1
1443             itypj=iabs(itype(j))
1444             if (itypj.eq.ntyp1) cycle
1445 c            dscj_inv=dsc_inv(itypj)
1446             dscj_inv=vbld_inv(j+nres)
1447 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1448 c     &       1.0d0/vbld(j+nres)
1449 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1450             sig0ij=sigma(itypi,itypj)
1451             chi1=chi(itypi,itypj)
1452             chi2=chi(itypj,itypi)
1453             chi12=chi1*chi2
1454             chip1=chip(itypi)
1455             chip2=chip(itypj)
1456             chip12=chip1*chip2
1457             alf1=alp(itypi)
1458             alf2=alp(itypj)
1459             alf12=0.5D0*(alf1+alf2)
1460 C For diagnostics only!!!
1461 c           chi1=0.0D0
1462 c           chi2=0.0D0
1463 c           chi12=0.0D0
1464 c           chip1=0.0D0
1465 c           chip2=0.0D0
1466 c           chip12=0.0D0
1467 c           alf1=0.0D0
1468 c           alf2=0.0D0
1469 c           alf12=0.0D0
1470             xj=c(1,nres+j)-xi
1471             yj=c(2,nres+j)-yi
1472             zj=c(3,nres+j)-zi
1473             dxj=dc_norm(1,nres+j)
1474             dyj=dc_norm(2,nres+j)
1475             dzj=dc_norm(3,nres+j)
1476 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1477 c            write (iout,*) "j",j," dc_norm",
1478 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480             rij=dsqrt(rrij)
1481 C Calculate angle-dependent terms of energy and contributions to their
1482 C derivatives.
1483             call sc_angular
1484             sigsq=1.0D0/sigsq
1485             sig=sig0ij*dsqrt(sigsq)
1486             rij_shift=1.0D0/rij-sig+sig0ij
1487 c for diagnostics; uncomment
1488 c            rij_shift=1.2*sig0ij
1489 C I hate to put IF's in the loops, but here don't have another choice!!!!
1490             if (rij_shift.le.0.0D0) then
1491               evdw=1.0D20
1492 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1495               return
1496             endif
1497             sigder=-sig*sigsq
1498 c---------------------------------------------------------------
1499             rij_shift=1.0D0/rij_shift
1500             fac=rij_shift**expon
1501             e1=fac*fac*aa(itypi,itypj)
1502             e2=fac*bb(itypi,itypj)
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1507 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1508             evdwij=evdwij*eps2rt*eps3rt
1509             evdw=evdw+evdwij
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1514      &        restyp(itypi),i,restyp(itypj),j,
1515      &        epsi,sigm,chi1,chi2,chip1,chip2,
1516      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1517      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1518      &        evdwij
1519             endif
1520
1521             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1522      &                        'evdw',i,j,evdwij
1523
1524 C Calculate gradient components.
1525             e1=e1*eps1*eps2rt**2*eps3rt**2
1526             fac=-expon*(e1+evdwij)*rij_shift
1527             sigder=fac*sigder
1528             fac=rij*fac
1529 c            fac=0.0d0
1530 C Calculate the radial part of the gradient
1531             gg(1)=xj*fac
1532             gg(2)=yj*fac
1533             gg(3)=zj*fac
1534 C Calculate angular part of the gradient.
1535             call sc_grad
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c      write (iout,*) "Number of loop steps in EGB:",ind
1540 cccc      energy_dec=.false.
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egbv(evdw)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne-Vorobjev potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       common /srutu/ icall
1561       logical lprn
1562       evdw=0.0D0
1563 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1564       evdw=0.0D0
1565       lprn=.false.
1566 c     if (icall.eq.0) lprn=.true.
1567       ind=0
1568       do i=iatsc_s,iatsc_e
1569         itypi=iabs(itype(i))
1570         if (itypi.eq.ntyp1) cycle
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 C
1581 C Calculate SC interaction energy.
1582 C
1583         do iint=1,nint_gr(i)
1584           do j=istart(i,iint),iend(i,iint)
1585             ind=ind+1
1586             itypj=iabs(itype(j))
1587             if (itypj.eq.ntyp1) cycle
1588 c            dscj_inv=dsc_inv(itypj)
1589             dscj_inv=vbld_inv(j+nres)
1590             sig0ij=sigma(itypi,itypj)
1591             r0ij=r0(itypi,itypj)
1592             chi1=chi(itypi,itypj)
1593             chi2=chi(itypj,itypi)
1594             chi12=chi1*chi2
1595             chip1=chip(itypi)
1596             chip2=chip(itypj)
1597             chip12=chip1*chip2
1598             alf1=alp(itypi)
1599             alf2=alp(itypj)
1600             alf12=0.5D0*(alf1+alf2)
1601 C For diagnostics only!!!
1602 c           chi1=0.0D0
1603 c           chi2=0.0D0
1604 c           chi12=0.0D0
1605 c           chip1=0.0D0
1606 c           chip2=0.0D0
1607 c           chip12=0.0D0
1608 c           alf1=0.0D0
1609 c           alf2=0.0D0
1610 c           alf12=0.0D0
1611             xj=c(1,nres+j)-xi
1612             yj=c(2,nres+j)-yi
1613             zj=c(3,nres+j)-zi
1614             dxj=dc_norm(1,nres+j)
1615             dyj=dc_norm(2,nres+j)
1616             dzj=dc_norm(3,nres+j)
1617             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1618             rij=dsqrt(rrij)
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+r0ij
1625 C I hate to put IF's in the loops, but here don't have another choice!!!!
1626             if (rij_shift.le.0.0D0) then
1627               evdw=1.0D20
1628               return
1629             endif
1630             sigder=-sig*sigsq
1631 c---------------------------------------------------------------
1632             rij_shift=1.0D0/rij_shift
1633             fac=rij_shift**expon
1634             e1=fac*fac*aa(itypi,itypj)
1635             e2=fac*bb(itypi,itypj)
1636             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1637             eps2der=evdwij*eps3rt
1638             eps3der=evdwij*eps2rt
1639             fac_augm=rrij**expon
1640             e_augm=augm(itypi,itypj)*fac_augm
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij+e_augm
1643             if (lprn) then
1644             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1645             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647      &        restyp(itypi),i,restyp(itypj),j,
1648      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1649      &        chi1,chi2,chip1,chip2,
1650      &        eps1,eps2rt**2,eps3rt**2,
1651      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1652      &        evdwij+e_augm
1653             endif
1654 C Calculate gradient components.
1655             e1=e1*eps1*eps2rt**2*eps3rt**2
1656             fac=-expon*(e1+evdwij)*rij_shift
1657             sigder=fac*sigder
1658             fac=rij*fac-2*expon*rrij*e_augm
1659 C Calculate the radial part of the gradient
1660             gg(1)=xj*fac
1661             gg(2)=yj*fac
1662             gg(3)=zj*fac
1663 C Calculate angular part of the gradient.
1664             call sc_grad
1665           enddo      ! j
1666         enddo        ! iint
1667       enddo          ! i
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine sc_angular
1671 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1672 C om12. Called by ebp, egb, and egbv.
1673       implicit none
1674       include 'COMMON.CALC'
1675       include 'COMMON.IOUNITS'
1676       erij(1)=xj*rij
1677       erij(2)=yj*rij
1678       erij(3)=zj*rij
1679       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1680       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1681       om12=dxi*dxj+dyi*dyj+dzi*dzj
1682       chiom12=chi12*om12
1683 C Calculate eps1(om12) and its derivative in om12
1684       faceps1=1.0D0-om12*chiom12
1685       faceps1_inv=1.0D0/faceps1
1686       eps1=dsqrt(faceps1_inv)
1687 C Following variable is eps1*deps1/dom12
1688       eps1_om12=faceps1_inv*chiom12
1689 c diagnostics only
1690 c      faceps1_inv=om12
1691 c      eps1=om12
1692 c      eps1_om12=1.0d0
1693 c      write (iout,*) "om12",om12," eps1",eps1
1694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1695 C and om12.
1696       om1om2=om1*om2
1697       chiom1=chi1*om1
1698       chiom2=chi2*om2
1699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1700       sigsq=1.0D0-facsig*faceps1_inv
1701       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1702       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1703       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1704 c diagnostics only
1705 c      sigsq=1.0d0
1706 c      sigsq_om1=0.0d0
1707 c      sigsq_om2=0.0d0
1708 c      sigsq_om12=0.0d0
1709 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1710 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1711 c     &    " eps1",eps1
1712 C Calculate eps2 and its derivatives in om1, om2, and om12.
1713       chipom1=chip1*om1
1714       chipom2=chip2*om2
1715       chipom12=chip12*om12
1716       facp=1.0D0-om12*chipom12
1717       facp_inv=1.0D0/facp
1718       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1719 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1720 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1721 C Following variable is the square root of eps2
1722       eps2rt=1.0D0-facp1*facp_inv
1723 C Following three variables are the derivatives of the square root of eps
1724 C in om1, om2, and om12.
1725       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1726       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1727       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1728 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1729       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1730 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1731 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1732 c     &  " eps2rt_om12",eps2rt_om12
1733 C Calculate whole angle-dependent part of epsilon and contributions
1734 C to its derivatives
1735       return
1736       end
1737 C----------------------------------------------------------------------------
1738       subroutine sc_grad
1739       implicit real*8 (a-h,o-z)
1740       include 'DIMENSIONS'
1741       include 'COMMON.CHAIN'
1742       include 'COMMON.DERIV'
1743       include 'COMMON.CALC'
1744       include 'COMMON.IOUNITS'
1745       double precision dcosom1(3),dcosom2(3)
1746       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1747       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1748       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1749      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1750 c diagnostics only
1751 c      eom1=0.0d0
1752 c      eom2=0.0d0
1753 c      eom12=evdwij*eps1_om12
1754 c end diagnostics
1755 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1756 c     &  " sigder",sigder
1757 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1758 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1759       do k=1,3
1760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1762       enddo
1763       do k=1,3
1764         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1765       enddo
1766 c      write (iout,*) "gg",(gg(k),k=1,3)
1767       do k=1,3
1768         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1769      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1770      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1771         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1772      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1775 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1776 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1777 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1778       enddo
1779 C
1780 C Calculate the components of the gradient in DC and X
1781 C
1782 cgrad      do k=i,j-1
1783 cgrad        do l=1,3
1784 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1785 cgrad        enddo
1786 cgrad      enddo
1787       do l=1,3
1788         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1789         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1790       enddo
1791       return
1792       end
1793 C-----------------------------------------------------------------------
1794       subroutine e_softsphere(evdw)
1795 C
1796 C This subroutine calculates the interaction energy of nonbonded side chains
1797 C assuming the LJ potential of interaction.
1798 C
1799       implicit real*8 (a-h,o-z)
1800       include 'DIMENSIONS'
1801       parameter (accur=1.0d-10)
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.INTERACT'
1808       include 'COMMON.TORSION'
1809       include 'COMMON.SBRIDGE'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CONTACTS'
1813       dimension gg(3)
1814 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823 C
1824 C Calculate SC interaction energy.
1825 C
1826         do iint=1,nint_gr(i)
1827 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1828 cd   &                  'iend=',iend(i,iint)
1829           do j=istart(i,iint),iend(i,iint)
1830             itypj=iabs(itype(j))
1831             if (itypj.eq.ntyp1) cycle
1832             xj=c(1,nres+j)-xi
1833             yj=c(2,nres+j)-yi
1834             zj=c(3,nres+j)-zi
1835             rij=xj*xj+yj*yj+zj*zj
1836 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1837             r0ij=r0(itypi,itypj)
1838             r0ijsq=r0ij*r0ij
1839 c            print *,i,j,r0ij,dsqrt(rij)
1840             if (rij.lt.r0ijsq) then
1841               evdwij=0.25d0*(rij-r0ijsq)**2
1842               fac=rij-r0ijsq
1843             else
1844               evdwij=0.0d0
1845               fac=0.0d0
1846             endif
1847             evdw=evdw+evdwij
1848 C
1849 C Calculate the components of the gradient in DC and X
1850 C
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854             do k=1,3
1855               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1856               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1857               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1858               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1859             enddo
1860 cgrad            do k=i,j-1
1861 cgrad              do l=1,3
1862 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1863 cgrad              enddo
1864 cgrad            enddo
1865           enddo ! j
1866         enddo ! iint
1867       enddo ! i
1868       return
1869       end
1870 C--------------------------------------------------------------------------
1871       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1872      &              eello_turn4)
1873 C
1874 C Soft-sphere potential of p-p interaction
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       include 'COMMON.CONTROL'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.GEO'
1881       include 'COMMON.VAR'
1882       include 'COMMON.LOCAL'
1883       include 'COMMON.CHAIN'
1884       include 'COMMON.DERIV'
1885       include 'COMMON.INTERACT'
1886       include 'COMMON.CONTACTS'
1887       include 'COMMON.TORSION'
1888       include 'COMMON.VECTORS'
1889       include 'COMMON.FFIELD'
1890       dimension ggg(3)
1891 cd      write(iout,*) 'In EELEC_soft_sphere'
1892       ees=0.0D0
1893       evdw1=0.0D0
1894       eel_loc=0.0d0
1895       eello_turn3=0.0d0
1896       eello_turn4=0.0d0
1897       ind=0
1898       do i=iatel_s,iatel_e
1899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1900         dxi=dc(1,i)
1901         dyi=dc(2,i)
1902         dzi=dc(3,i)
1903         xmedi=c(1,i)+0.5d0*dxi
1904         ymedi=c(2,i)+0.5d0*dyi
1905         zmedi=c(3,i)+0.5d0*dzi
1906         num_conti=0
1907 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1908         do j=ielstart(i),ielend(i)
1909           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1910           ind=ind+1
1911           iteli=itel(i)
1912           itelj=itel(j)
1913           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1914           r0ij=rpp(iteli,itelj)
1915           r0ijsq=r0ij*r0ij
1916           dxj=dc(1,j)
1917           dyj=dc(2,j)
1918           dzj=dc(3,j)
1919           xj=c(1,j)+0.5D0*dxj-xmedi
1920           yj=c(2,j)+0.5D0*dyj-ymedi
1921           zj=c(3,j)+0.5D0*dzj-zmedi
1922           rij=xj*xj+yj*yj+zj*zj
1923           if (rij.lt.r0ijsq) then
1924             evdw1ij=0.25d0*(rij-r0ijsq)**2
1925             fac=rij-r0ijsq
1926           else
1927             evdw1ij=0.0d0
1928             fac=0.0d0
1929           endif
1930           evdw1=evdw1+evdw1ij
1931 C
1932 C Calculate contributions to the Cartesian gradient.
1933 C
1934           ggg(1)=fac*xj
1935           ggg(2)=fac*yj
1936           ggg(3)=fac*zj
1937           do k=1,3
1938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1940           enddo
1941 *
1942 * Loop over residues i+1 thru j-1.
1943 *
1944 cgrad          do k=i+1,j-1
1945 cgrad            do l=1,3
1946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1947 cgrad            enddo
1948 cgrad          enddo
1949         enddo ! j
1950       enddo   ! i
1951 cgrad      do i=nnt,nct-1
1952 cgrad        do k=1,3
1953 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1954 cgrad        enddo
1955 cgrad        do j=i+1,nct-1
1956 cgrad          do k=1,3
1957 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1958 cgrad          enddo
1959 cgrad        enddo
1960 cgrad      enddo
1961       return
1962       end
1963 c------------------------------------------------------------------------------
1964       subroutine vec_and_deriv
1965       implicit real*8 (a-h,o-z)
1966       include 'DIMENSIONS'
1967 #ifdef MPI
1968       include 'mpif.h'
1969 #endif
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.VECTORS'
1976       include 'COMMON.SETUP'
1977       include 'COMMON.TIME1'
1978       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1979 C Compute the local reference systems. For reference system (i), the
1980 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1981 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1982 #ifdef PARVEC
1983       do i=ivec_start,ivec_end
1984 #else
1985       do i=1,nres-1
1986 #endif
1987           if (i.eq.nres-1) then
1988 C Case of the last full residue
1989 C Compute the Z-axis
1990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1991             costh=dcos(pi-theta(nres))
1992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1993             do k=1,3
1994               uz(k,i)=fac*uz(k,i)
1995             enddo
1996 C Compute the derivatives of uz
1997             uzder(1,1,1)= 0.0d0
1998             uzder(2,1,1)=-dc_norm(3,i-1)
1999             uzder(3,1,1)= dc_norm(2,i-1)
2000             uzder(1,2,1)= dc_norm(3,i-1)
2001             uzder(2,2,1)= 0.0d0
2002             uzder(3,2,1)=-dc_norm(1,i-1)
2003             uzder(1,3,1)=-dc_norm(2,i-1)
2004             uzder(2,3,1)= dc_norm(1,i-1)
2005             uzder(3,3,1)= 0.0d0
2006             uzder(1,1,2)= 0.0d0
2007             uzder(2,1,2)= dc_norm(3,i)
2008             uzder(3,1,2)=-dc_norm(2,i)
2009             uzder(1,2,2)=-dc_norm(3,i)
2010             uzder(2,2,2)= 0.0d0
2011             uzder(3,2,2)= dc_norm(1,i)
2012             uzder(1,3,2)= dc_norm(2,i)
2013             uzder(2,3,2)=-dc_norm(1,i)
2014             uzder(3,3,2)= 0.0d0
2015 C Compute the Y-axis
2016             facy=fac
2017             do k=1,3
2018               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2019             enddo
2020 C Compute the derivatives of uy
2021             do j=1,3
2022               do k=1,3
2023                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2024      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2025                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2026               enddo
2027               uyder(j,j,1)=uyder(j,j,1)-costh
2028               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2029             enddo
2030             do j=1,2
2031               do k=1,3
2032                 do l=1,3
2033                   uygrad(l,k,j,i)=uyder(l,k,j)
2034                   uzgrad(l,k,j,i)=uzder(l,k,j)
2035                 enddo
2036               enddo
2037             enddo
2038             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2039             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2040             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2041             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2042           else
2043 C Other residues
2044 C Compute the Z-axis
2045             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2046             costh=dcos(pi-theta(i+2))
2047             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2048             do k=1,3
2049               uz(k,i)=fac*uz(k,i)
2050             enddo
2051 C Compute the derivatives of uz
2052             uzder(1,1,1)= 0.0d0
2053             uzder(2,1,1)=-dc_norm(3,i+1)
2054             uzder(3,1,1)= dc_norm(2,i+1)
2055             uzder(1,2,1)= dc_norm(3,i+1)
2056             uzder(2,2,1)= 0.0d0
2057             uzder(3,2,1)=-dc_norm(1,i+1)
2058             uzder(1,3,1)=-dc_norm(2,i+1)
2059             uzder(2,3,1)= dc_norm(1,i+1)
2060             uzder(3,3,1)= 0.0d0
2061             uzder(1,1,2)= 0.0d0
2062             uzder(2,1,2)= dc_norm(3,i)
2063             uzder(3,1,2)=-dc_norm(2,i)
2064             uzder(1,2,2)=-dc_norm(3,i)
2065             uzder(2,2,2)= 0.0d0
2066             uzder(3,2,2)= dc_norm(1,i)
2067             uzder(1,3,2)= dc_norm(2,i)
2068             uzder(2,3,2)=-dc_norm(1,i)
2069             uzder(3,3,2)= 0.0d0
2070 C Compute the Y-axis
2071             facy=fac
2072             do k=1,3
2073               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2074             enddo
2075 C Compute the derivatives of uy
2076             do j=1,3
2077               do k=1,3
2078                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2079      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2080                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2081               enddo
2082               uyder(j,j,1)=uyder(j,j,1)-costh
2083               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2084             enddo
2085             do j=1,2
2086               do k=1,3
2087                 do l=1,3
2088                   uygrad(l,k,j,i)=uyder(l,k,j)
2089                   uzgrad(l,k,j,i)=uzder(l,k,j)
2090                 enddo
2091               enddo
2092             enddo
2093             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2094             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2095             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2096             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2097           endif
2098       enddo
2099       do i=1,nres-1
2100         vbld_inv_temp(1)=vbld_inv(i+1)
2101         if (i.lt.nres-1) then
2102           vbld_inv_temp(2)=vbld_inv(i+2)
2103           else
2104           vbld_inv_temp(2)=vbld_inv(i)
2105           endif
2106         do j=1,2
2107           do k=1,3
2108             do l=1,3
2109               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2110               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2111             enddo
2112           enddo
2113         enddo
2114       enddo
2115 #if defined(PARVEC) && defined(MPI)
2116       if (nfgtasks1.gt.1) then
2117         time00=MPI_Wtime()
2118 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2119 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2120 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2121         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2122      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2123      &   FG_COMM1,IERR)
2124         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2125      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2126      &   FG_COMM1,IERR)
2127         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2128      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2129      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2130         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2131      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2132      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2133         time_gather=time_gather+MPI_Wtime()-time00
2134       endif
2135 c      if (fg_rank.eq.0) then
2136 c        write (iout,*) "Arrays UY and UZ"
2137 c        do i=1,nres-1
2138 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2139 c     &     (uz(k,i),k=1,3)
2140 c        enddo
2141 c      endif
2142 #endif
2143       return
2144       end
2145 C-----------------------------------------------------------------------------
2146       subroutine check_vecgrad
2147       implicit real*8 (a-h,o-z)
2148       include 'DIMENSIONS'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.GEO'
2151       include 'COMMON.VAR'
2152       include 'COMMON.LOCAL'
2153       include 'COMMON.CHAIN'
2154       include 'COMMON.VECTORS'
2155       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2156       dimension uyt(3,maxres),uzt(3,maxres)
2157       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2158       double precision delta /1.0d-7/
2159       call vec_and_deriv
2160 cd      do i=1,nres
2161 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2162 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2163 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2165 cd     &     (dc_norm(if90,i),if90=1,3)
2166 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2167 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2168 cd          write(iout,'(a)')
2169 cd      enddo
2170       do i=1,nres
2171         do j=1,2
2172           do k=1,3
2173             do l=1,3
2174               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2175               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2176             enddo
2177           enddo
2178         enddo
2179       enddo
2180       call vec_and_deriv
2181       do i=1,nres
2182         do j=1,3
2183           uyt(j,i)=uy(j,i)
2184           uzt(j,i)=uz(j,i)
2185         enddo
2186       enddo
2187       do i=1,nres
2188 cd        write (iout,*) 'i=',i
2189         do k=1,3
2190           erij(k)=dc_norm(k,i)
2191         enddo
2192         do j=1,3
2193           do k=1,3
2194             dc_norm(k,i)=erij(k)
2195           enddo
2196           dc_norm(j,i)=dc_norm(j,i)+delta
2197 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2198 c          do k=1,3
2199 c            dc_norm(k,i)=dc_norm(k,i)/fac
2200 c          enddo
2201 c          write (iout,*) (dc_norm(k,i),k=1,3)
2202 c          write (iout,*) (erij(k),k=1,3)
2203           call vec_and_deriv
2204           do k=1,3
2205             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2206             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2207             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2208             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2209           enddo
2210 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2211 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2212 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2213         enddo
2214         do k=1,3
2215           dc_norm(k,i)=erij(k)
2216         enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2219 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2220 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2221 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2222 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2223 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2224 cd          write (iout,'(a)')
2225 cd        enddo
2226       enddo
2227       return
2228       end
2229 C--------------------------------------------------------------------------
2230       subroutine set_matrices
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233 #ifdef MPI
2234       include "mpif.h"
2235       include "COMMON.SETUP"
2236       integer IERR
2237       integer status(MPI_STATUS_SIZE)
2238 #endif
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.GEO'
2241       include 'COMMON.VAR'
2242       include 'COMMON.LOCAL'
2243       include 'COMMON.CHAIN'
2244       include 'COMMON.DERIV'
2245       include 'COMMON.INTERACT'
2246       include 'COMMON.CONTACTS'
2247       include 'COMMON.TORSION'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.FFIELD'
2250       double precision auxvec(2),auxmat(2,2)
2251 C
2252 C Compute the virtual-bond-torsional-angle dependent quantities needed
2253 C to calculate the el-loc multibody terms of various order.
2254 C
2255 c      write(iout,*) 'nphi=',nphi,nres
2256 #ifdef PARMAT
2257       do i=ivec_start+2,ivec_end+2
2258 #else
2259       do i=3,nres+1
2260 #endif
2261 #ifdef NEWCORR
2262         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2263           iti = itortyp(itype(i-2))
2264         else
2265           iti=ntortyp+1
2266         endif
2267 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2268         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2269           iti1 = itortyp(itype(i-1))
2270         else
2271           iti1=ntortyp+1
2272         endif
2273 c        write(iout,*),i
2274         b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0)
2275      &           +bnew1(2,1,iti)*sin(theta(i-1))
2276      &           +bnew1(3,1,iti)*cos(theta(i-1)/2.0)
2277         gtb1(1,i-2)=bnew1(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2278      &             +bnew1(2,1,iti)*cos(theta(i-1))
2279      &             -bnew1(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2280 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2281 c     &*(cos(theta(i)/2.0)
2282         b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0)
2283      &           +bnew2(2,1,iti)*sin(theta(i-1))
2284      &           +bnew2(3,1,iti)*cos(theta(i-1)/2.0)
2285 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2286 c     &*(cos(theta(i)/2.0)
2287         gtb2(1,i-2)=bnew2(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2288      &             +bnew2(2,1,iti)*cos(theta(i-1))
2289      &             -bnew2(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2290 c        if (ggb1(1,i).eq.0.0d0) then
2291 c        write(iout,*) 'i=',i,ggb1(1,i),
2292 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2293 c     &bnew1(2,1,iti)*cos(theta(i)),
2294 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2295 c        endif
2296         b1(2,i-2)=bnew1(1,2,iti)
2297         gtb1(2,i-2)=0.0
2298         b2(2,i-2)=bnew2(1,2,iti)
2299         gtb2(2,i-2)=0.0
2300         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2301         EE(1,2,i-2)=eeold(1,2,iti)
2302         EE(2,1,i-2)=eeold(2,1,iti)
2303         EE(2,2,i-2)=eeold(2,2,iti)
2304         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2305         gtEE(1,2,i-2)=0.0d0
2306         gtEE(2,2,i-2)=0.0d0
2307         gtEE(2,1,i-2)=0.0d0
2308 c        EE(2,2,iti)=0.0d0
2309 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2310 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2311 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2312 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2313        b1tilde(1,i-2)=b1(1,i-2)
2314        b1tilde(2,i-2)=-b1(2,i-2)
2315        b2tilde(1,i-2)=b2(1,i-2)
2316        b2tilde(2,i-2)=-b2(2,i-2)
2317 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2318 c       write (iout,*) 'theta=', theta(i-1)
2319        enddo
2320 #ifdef PARMAT
2321       do i=ivec_start+2,ivec_end+2
2322 #else
2323       do i=3,nres+1
2324 #endif
2325 #endif
2326         if (i .lt. nres+1) then
2327           sin1=dsin(phi(i))
2328           cos1=dcos(phi(i))
2329           sintab(i-2)=sin1
2330           costab(i-2)=cos1
2331           obrot(1,i-2)=cos1
2332           obrot(2,i-2)=sin1
2333           sin2=dsin(2*phi(i))
2334           cos2=dcos(2*phi(i))
2335           sintab2(i-2)=sin2
2336           costab2(i-2)=cos2
2337           obrot2(1,i-2)=cos2
2338           obrot2(2,i-2)=sin2
2339           Ug(1,1,i-2)=-cos1
2340           Ug(1,2,i-2)=-sin1
2341           Ug(2,1,i-2)=-sin1
2342           Ug(2,2,i-2)= cos1
2343           Ug2(1,1,i-2)=-cos2
2344           Ug2(1,2,i-2)=-sin2
2345           Ug2(2,1,i-2)=-sin2
2346           Ug2(2,2,i-2)= cos2
2347         else
2348           costab(i-2)=1.0d0
2349           sintab(i-2)=0.0d0
2350           obrot(1,i-2)=1.0d0
2351           obrot(2,i-2)=0.0d0
2352           obrot2(1,i-2)=0.0d0
2353           obrot2(2,i-2)=0.0d0
2354           Ug(1,1,i-2)=1.0d0
2355           Ug(1,2,i-2)=0.0d0
2356           Ug(2,1,i-2)=0.0d0
2357           Ug(2,2,i-2)=1.0d0
2358           Ug2(1,1,i-2)=0.0d0
2359           Ug2(1,2,i-2)=0.0d0
2360           Ug2(2,1,i-2)=0.0d0
2361           Ug2(2,2,i-2)=0.0d0
2362         endif
2363         if (i .gt. 3 .and. i .lt. nres+1) then
2364           obrot_der(1,i-2)=-sin1
2365           obrot_der(2,i-2)= cos1
2366           Ugder(1,1,i-2)= sin1
2367           Ugder(1,2,i-2)=-cos1
2368           Ugder(2,1,i-2)=-cos1
2369           Ugder(2,2,i-2)=-sin1
2370           dwacos2=cos2+cos2
2371           dwasin2=sin2+sin2
2372           obrot2_der(1,i-2)=-dwasin2
2373           obrot2_der(2,i-2)= dwacos2
2374           Ug2der(1,1,i-2)= dwasin2
2375           Ug2der(1,2,i-2)=-dwacos2
2376           Ug2der(2,1,i-2)=-dwacos2
2377           Ug2der(2,2,i-2)=-dwasin2
2378         else
2379           obrot_der(1,i-2)=0.0d0
2380           obrot_der(2,i-2)=0.0d0
2381           Ugder(1,1,i-2)=0.0d0
2382           Ugder(1,2,i-2)=0.0d0
2383           Ugder(2,1,i-2)=0.0d0
2384           Ugder(2,2,i-2)=0.0d0
2385           obrot2_der(1,i-2)=0.0d0
2386           obrot2_der(2,i-2)=0.0d0
2387           Ug2der(1,1,i-2)=0.0d0
2388           Ug2der(1,2,i-2)=0.0d0
2389           Ug2der(2,1,i-2)=0.0d0
2390           Ug2der(2,2,i-2)=0.0d0
2391         endif
2392 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2393         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2394           iti = itortyp(itype(i-2))
2395         else
2396           iti=ntortyp+1
2397         endif
2398 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2399         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2400           iti1 = itortyp(itype(i-1))
2401         else
2402           iti1=ntortyp+1
2403         endif
2404 cd        write (iout,*) '*******i',i,' iti1',iti
2405 cd        write (iout,*) 'b1',b1(:,iti)
2406 cd        write (iout,*) 'b2',b2(:,iti)
2407 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2408 c        if (i .gt. iatel_s+2) then
2409         if (i .gt. nnt+2) then
2410           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2411 #ifdef NEWCORR
2412           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2413 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2414 #endif
2415 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2416 c     &    EE(1,2,iti),EE(2,2,iti)
2417           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2418           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2419 c          write(iout,*) "Macierz EUG",
2420 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2421 c     &    eug(2,2,i-2)
2422           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2423      &    then
2424           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2425           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2426           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2427           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2428           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2429           endif
2430         else
2431           do k=1,2
2432             Ub2(k,i-2)=0.0d0
2433             Ctobr(k,i-2)=0.0d0
2434             Dtobr2(k,i-2)=0.0d0
2435             do l=1,2
2436               EUg(l,k,i-2)=0.0d0
2437               CUg(l,k,i-2)=0.0d0
2438               DUg(l,k,i-2)=0.0d0
2439               DtUg2(l,k,i-2)=0.0d0
2440             enddo
2441           enddo
2442         endif
2443         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2444         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2445         do k=1,2
2446           muder(k,i-2)=Ub2der(k,i-2)
2447         enddo
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           if (itype(i-1).le.ntyp) then
2451             iti1 = itortyp(itype(i-1))
2452           else
2453             iti1=ntortyp+1
2454           endif
2455         else
2456           iti1=ntortyp+1
2457         endif
2458         do k=1,2
2459           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2460         enddo
2461 #ifdef MUOUT
2462         write (iout,'(2hmu,i3,3f8.1,7f10.5)') i-2,rad2deg*theta(i-1),
2463      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2464      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2465      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2466      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2)
2467 #endif
2468 cd        write (iout,*) 'mu ',mu(:,i-2)
2469 cd        write (iout,*) 'mu1',mu1(:,i-2)
2470 cd        write (iout,*) 'mu2',mu2(:,i-2)
2471         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2472      &  then
2473         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2474         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2475         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2476         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2477         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2478 C Vectors and matrices dependent on a single virtual-bond dihedral.
2479         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2480         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2481         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2482         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2483         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2484         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2485         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2486         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2487         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2488         endif
2489       enddo
2490 C Matrices dependent on two consecutive virtual-bond dihedrals.
2491 C The order of matrices is from left to right.
2492       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2493      &then
2494 c      do i=max0(ivec_start,2),ivec_end
2495       do i=2,nres-1
2496         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2497         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2498         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2499         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2500         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2501         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2502         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2503         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2504       enddo
2505       endif
2506 #if defined(MPI) && defined(PARMAT)
2507 #ifdef DEBUG
2508 c      if (fg_rank.eq.0) then
2509         write (iout,*) "Arrays UG and UGDER before GATHER"
2510         do i=1,nres-1
2511           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2512      &     ((ug(l,k,i),l=1,2),k=1,2),
2513      &     ((ugder(l,k,i),l=1,2),k=1,2)
2514         enddo
2515         write (iout,*) "Arrays UG2 and UG2DER"
2516         do i=1,nres-1
2517           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2518      &     ((ug2(l,k,i),l=1,2),k=1,2),
2519      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2520         enddo
2521         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2522         do i=1,nres-1
2523           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2524      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2525      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2526         enddo
2527         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2528         do i=1,nres-1
2529           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2530      &     costab(i),sintab(i),costab2(i),sintab2(i)
2531         enddo
2532         write (iout,*) "Array MUDER"
2533         do i=1,nres-1
2534           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2535         enddo
2536 c      endif
2537 #endif
2538       if (nfgtasks.gt.1) then
2539         time00=MPI_Wtime()
2540 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2541 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2542 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2543 #ifdef MATGATHER
2544         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2548      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2549      &   FG_COMM1,IERR)
2550         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2552      &   FG_COMM1,IERR)
2553         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2555      &   FG_COMM1,IERR)
2556         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2557      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2558      &   FG_COMM1,IERR)
2559         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2560      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2563      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2564      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2565         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2566      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2567      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2568         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2569      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2570      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2571         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2572      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2573      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2574         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2575      &  then
2576         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2577      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2578      &   FG_COMM1,IERR)
2579         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2580      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2581      &   FG_COMM1,IERR)
2582         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2583      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2584      &   FG_COMM1,IERR)
2585        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2586      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2587      &   FG_COMM1,IERR)
2588         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2589      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2590      &   FG_COMM1,IERR)
2591         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2592      &   ivec_count(fg_rank1),
2593      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2594      &   FG_COMM1,IERR)
2595         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2596      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2597      &   FG_COMM1,IERR)
2598         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2599      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2600      &   FG_COMM1,IERR)
2601         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2602      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2603      &   FG_COMM1,IERR)
2604         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2605      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2606      &   FG_COMM1,IERR)
2607         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2608      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2609      &   FG_COMM1,IERR)
2610         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2611      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2612      &   FG_COMM1,IERR)
2613         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2614      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2615      &   FG_COMM1,IERR)
2616         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2617      &   ivec_count(fg_rank1),
2618      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2619      &   FG_COMM1,IERR)
2620         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2621      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2622      &   FG_COMM1,IERR)
2623        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2624      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2625      &   FG_COMM1,IERR)
2626         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2627      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2628      &   FG_COMM1,IERR)
2629        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2630      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2631      &   FG_COMM1,IERR)
2632         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2633      &   ivec_count(fg_rank1),
2634      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2635      &   FG_COMM1,IERR)
2636         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2637      &   ivec_count(fg_rank1),
2638      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2641      &   ivec_count(fg_rank1),
2642      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2643      &   MPI_MAT2,FG_COMM1,IERR)
2644         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2645      &   ivec_count(fg_rank1),
2646      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2647      &   MPI_MAT2,FG_COMM1,IERR)
2648         endif
2649 #else
2650 c Passes matrix info through the ring
2651       isend=fg_rank1
2652       irecv=fg_rank1-1
2653       if (irecv.lt.0) irecv=nfgtasks1-1
2654       iprev=irecv
2655       inext=fg_rank1+1
2656       if (inext.ge.nfgtasks1) inext=0
2657       do i=1,nfgtasks1-1
2658 c        write (iout,*) "isend",isend," irecv",irecv
2659 c        call flush(iout)
2660         lensend=lentyp(isend)
2661         lenrecv=lentyp(irecv)
2662 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2663 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2664 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2665 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2666 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2667 c        write (iout,*) "Gather ROTAT1"
2668 c        call flush(iout)
2669 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2670 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2671 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2672 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2673 c        write (iout,*) "Gather ROTAT2"
2674 c        call flush(iout)
2675         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2676      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2677      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2678      &   iprev,4400+irecv,FG_COMM,status,IERR)
2679 c        write (iout,*) "Gather ROTAT_OLD"
2680 c        call flush(iout)
2681         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2682      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2683      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2684      &   iprev,5500+irecv,FG_COMM,status,IERR)
2685 c        write (iout,*) "Gather PRECOMP11"
2686 c        call flush(iout)
2687         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2688      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2689      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2690      &   iprev,6600+irecv,FG_COMM,status,IERR)
2691 c        write (iout,*) "Gather PRECOMP12"
2692 c        call flush(iout)
2693         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2694      &  then
2695         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2696      &   MPI_ROTAT2(lensend),inext,7700+isend,
2697      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2698      &   iprev,7700+irecv,FG_COMM,status,IERR)
2699 c        write (iout,*) "Gather PRECOMP21"
2700 c        call flush(iout)
2701         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2702      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2703      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2704      &   iprev,8800+irecv,FG_COMM,status,IERR)
2705 c        write (iout,*) "Gather PRECOMP22"
2706 c        call flush(iout)
2707         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2708      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2709      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2710      &   MPI_PRECOMP23(lenrecv),
2711      &   iprev,9900+irecv,FG_COMM,status,IERR)
2712 c        write (iout,*) "Gather PRECOMP23"
2713 c        call flush(iout)
2714         endif
2715         isend=irecv
2716         irecv=irecv-1
2717         if (irecv.lt.0) irecv=nfgtasks1-1
2718       enddo
2719 #endif
2720         time_gather=time_gather+MPI_Wtime()-time00
2721       endif
2722 #ifdef DEBUG
2723 c      if (fg_rank.eq.0) then
2724         write (iout,*) "Arrays UG and UGDER"
2725         do i=1,nres-1
2726           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2727      &     ((ug(l,k,i),l=1,2),k=1,2),
2728      &     ((ugder(l,k,i),l=1,2),k=1,2)
2729         enddo
2730         write (iout,*) "Arrays UG2 and UG2DER"
2731         do i=1,nres-1
2732           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2733      &     ((ug2(l,k,i),l=1,2),k=1,2),
2734      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2735         enddo
2736         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2737         do i=1,nres-1
2738           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2739      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2740      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2741         enddo
2742         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2743         do i=1,nres-1
2744           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2745      &     costab(i),sintab(i),costab2(i),sintab2(i)
2746         enddo
2747         write (iout,*) "Array MUDER"
2748         do i=1,nres-1
2749           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2750         enddo
2751 c      endif
2752 #endif
2753 #endif
2754 cd      do i=1,nres
2755 cd        iti = itortyp(itype(i))
2756 cd        write (iout,*) i
2757 cd        do j=1,2
2758 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2759 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2760 cd        enddo
2761 cd      enddo
2762       return
2763       end
2764 C--------------------------------------------------------------------------
2765       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2766 C
2767 C This subroutine calculates the average interaction energy and its gradient
2768 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2769 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2770 C The potential depends both on the distance of peptide-group centers and on
2771 C the orientation of the CA-CA virtual bonds.
2772 C
2773       implicit real*8 (a-h,o-z)
2774 #ifdef MPI
2775       include 'mpif.h'
2776 #endif
2777       include 'DIMENSIONS'
2778       include 'COMMON.CONTROL'
2779       include 'COMMON.SETUP'
2780       include 'COMMON.IOUNITS'
2781       include 'COMMON.GEO'
2782       include 'COMMON.VAR'
2783       include 'COMMON.LOCAL'
2784       include 'COMMON.CHAIN'
2785       include 'COMMON.DERIV'
2786       include 'COMMON.INTERACT'
2787       include 'COMMON.CONTACTS'
2788       include 'COMMON.TORSION'
2789       include 'COMMON.VECTORS'
2790       include 'COMMON.FFIELD'
2791       include 'COMMON.TIME1'
2792       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2793      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2794       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2795      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2796       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2797      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2798      &    num_conti,j1,j2
2799 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2800 #ifdef MOMENT
2801       double precision scal_el /1.0d0/
2802 #else
2803       double precision scal_el /0.5d0/
2804 #endif
2805 C 12/13/98
2806 C 13-go grudnia roku pamietnego...
2807       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2808      &                   0.0d0,1.0d0,0.0d0,
2809      &                   0.0d0,0.0d0,1.0d0/
2810 cd      write(iout,*) 'In EELEC'
2811 cd      do i=1,nloctyp
2812 cd        write(iout,*) 'Type',i
2813 cd        write(iout,*) 'B1',B1(:,i)
2814 cd        write(iout,*) 'B2',B2(:,i)
2815 cd        write(iout,*) 'CC',CC(:,:,i)
2816 cd        write(iout,*) 'DD',DD(:,:,i)
2817 cd        write(iout,*) 'EE',EE(:,:,i)
2818 cd      enddo
2819 cd      call check_vecgrad
2820 cd      stop
2821       if (icheckgrad.eq.1) then
2822         do i=1,nres-1
2823           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2824           do k=1,3
2825             dc_norm(k,i)=dc(k,i)*fac
2826           enddo
2827 c          write (iout,*) 'i',i,' fac',fac
2828         enddo
2829       endif
2830       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2831      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2832      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2833 c        call vec_and_deriv
2834 #ifdef TIMING
2835         time01=MPI_Wtime()
2836 #endif
2837         call set_matrices
2838 #ifdef TIMING
2839         time_mat=time_mat+MPI_Wtime()-time01
2840 #endif
2841       endif
2842 cd      do i=1,nres-1
2843 cd        write (iout,*) 'i=',i
2844 cd        do k=1,3
2845 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2846 cd        enddo
2847 cd        do k=1,3
2848 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2849 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2850 cd        enddo
2851 cd      enddo
2852       t_eelecij=0.0d0
2853       ees=0.0D0
2854       evdw1=0.0D0
2855       eel_loc=0.0d0
2856       eello_turn3=0.0d0
2857       eello_turn4=0.0d0
2858       ind=0
2859       do i=1,nres
2860         num_cont_hb(i)=0
2861       enddo
2862 cd      print '(a)','Enter EELEC'
2863 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2864       do i=1,nres
2865         gel_loc_loc(i)=0.0d0
2866         gcorr_loc(i)=0.0d0
2867       enddo
2868 c
2869 c
2870 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2871 C
2872 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2873 C
2874       do i=iturn3_start,iturn3_end
2875         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2876      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2877         dxi=dc(1,i)
2878         dyi=dc(2,i)
2879         dzi=dc(3,i)
2880         dx_normi=dc_norm(1,i)
2881         dy_normi=dc_norm(2,i)
2882         dz_normi=dc_norm(3,i)
2883         xmedi=c(1,i)+0.5d0*dxi
2884         ymedi=c(2,i)+0.5d0*dyi
2885         zmedi=c(3,i)+0.5d0*dzi
2886         num_conti=0
2887         call eelecij(i,i+2,ees,evdw1,eel_loc)
2888         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2889         num_cont_hb(i)=num_conti
2890       enddo
2891       do i=iturn4_start,iturn4_end
2892         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2893      &    .or. itype(i+3).eq.ntyp1
2894      &    .or. itype(i+4).eq.ntyp1) cycle
2895         dxi=dc(1,i)
2896         dyi=dc(2,i)
2897         dzi=dc(3,i)
2898         dx_normi=dc_norm(1,i)
2899         dy_normi=dc_norm(2,i)
2900         dz_normi=dc_norm(3,i)
2901         xmedi=c(1,i)+0.5d0*dxi
2902         ymedi=c(2,i)+0.5d0*dyi
2903         zmedi=c(3,i)+0.5d0*dzi
2904         num_conti=num_cont_hb(i)
2905 c        write(iout,*) "JESTEM W PETLI"
2906         call eelecij(i,i+3,ees,evdw1,eel_loc)
2907         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2908      &   call eturn4(i,eello_turn4)
2909         num_cont_hb(i)=num_conti
2910       enddo   ! i
2911 c
2912 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2913 c
2914       do i=iatel_s,iatel_e
2915 c       do i=7,7
2916         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2917         dxi=dc(1,i)
2918         dyi=dc(2,i)
2919         dzi=dc(3,i)
2920         dx_normi=dc_norm(1,i)
2921         dy_normi=dc_norm(2,i)
2922         dz_normi=dc_norm(3,i)
2923         xmedi=c(1,i)+0.5d0*dxi
2924         ymedi=c(2,i)+0.5d0*dyi
2925         zmedi=c(3,i)+0.5d0*dzi
2926 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2927         num_conti=num_cont_hb(i)
2928         do j=ielstart(i),ielend(i)
2929 c         do j=13,13
2930 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2931           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2932           call eelecij(i,j,ees,evdw1,eel_loc)
2933         enddo ! j
2934         num_cont_hb(i)=num_conti
2935       enddo   ! i
2936 c      write (iout,*) "Number of loop steps in EELEC:",ind
2937 cd      do i=1,nres
2938 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2939 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2940 cd      enddo
2941 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2942 ccc      eel_loc=eel_loc+eello_turn3
2943 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2944       return
2945       end
2946 C-------------------------------------------------------------------------------
2947       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2948       implicit real*8 (a-h,o-z)
2949       include 'DIMENSIONS'
2950 #ifdef MPI
2951       include "mpif.h"
2952 #endif
2953       include 'COMMON.CONTROL'
2954       include 'COMMON.IOUNITS'
2955       include 'COMMON.GEO'
2956       include 'COMMON.VAR'
2957       include 'COMMON.LOCAL'
2958       include 'COMMON.CHAIN'
2959       include 'COMMON.DERIV'
2960       include 'COMMON.INTERACT'
2961       include 'COMMON.CONTACTS'
2962       include 'COMMON.TORSION'
2963       include 'COMMON.VECTORS'
2964       include 'COMMON.FFIELD'
2965       include 'COMMON.TIME1'
2966       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2967      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2968       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2969      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2970      &    gmuij2(4),gmuji2(4)
2971       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2972      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2973      &    num_conti,j1,j2
2974 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2975 #ifdef MOMENT
2976       double precision scal_el /1.0d0/
2977 #else
2978       double precision scal_el /0.5d0/
2979 #endif
2980 C 12/13/98
2981 C 13-go grudnia roku pamietnego...
2982       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2983      &                   0.0d0,1.0d0,0.0d0,
2984      &                   0.0d0,0.0d0,1.0d0/
2985 c          time00=MPI_Wtime()
2986 cd      write (iout,*) "eelecij",i,j
2987 c          ind=ind+1
2988           iteli=itel(i)
2989           itelj=itel(j)
2990           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2991           aaa=app(iteli,itelj)
2992           bbb=bpp(iteli,itelj)
2993           ael6i=ael6(iteli,itelj)
2994           ael3i=ael3(iteli,itelj)
2995           dxj=dc(1,j)
2996           dyj=dc(2,j)
2997           dzj=dc(3,j)
2998           dx_normj=dc_norm(1,j)
2999           dy_normj=dc_norm(2,j)
3000           dz_normj=dc_norm(3,j)
3001           xj=c(1,j)+0.5D0*dxj-xmedi
3002           yj=c(2,j)+0.5D0*dyj-ymedi
3003           zj=c(3,j)+0.5D0*dzj-zmedi
3004           rij=xj*xj+yj*yj+zj*zj
3005           rrmij=1.0D0/rij
3006           rij=dsqrt(rij)
3007           rmij=1.0D0/rij
3008           r3ij=rrmij*rmij
3009           r6ij=r3ij*r3ij
3010           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3011           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3012           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3013           fac=cosa-3.0D0*cosb*cosg
3014           ev1=aaa*r6ij*r6ij
3015 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3016           if (j.eq.i+2) ev1=scal_el*ev1
3017           ev2=bbb*r6ij
3018           fac3=ael6i*r6ij
3019           fac4=ael3i*r3ij
3020           evdwij=ev1+ev2
3021           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3022           el2=fac4*fac
3023           eesij=el1+el2
3024 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3025           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3026           ees=ees+eesij
3027           evdw1=evdw1+evdwij
3028 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3029 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3030 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3031 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3032
3033           if (energy_dec) then
3034               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3035      &'evdw1',i,j,evdwij
3036      &,iteli,itelj,aaa,evdw1
3037               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3038           endif
3039
3040 C
3041 C Calculate contributions to the Cartesian gradient.
3042 C
3043 #ifdef SPLITELE
3044           facvdw=-6*rrmij*(ev1+evdwij)
3045           facel=-3*rrmij*(el1+eesij)
3046           fac1=fac
3047           erij(1)=xj*rmij
3048           erij(2)=yj*rmij
3049           erij(3)=zj*rmij
3050 *
3051 * Radial derivatives. First process both termini of the fragment (i,j)
3052 *
3053           ggg(1)=facel*xj
3054           ggg(2)=facel*yj
3055           ggg(3)=facel*zj
3056 c          do k=1,3
3057 c            ghalf=0.5D0*ggg(k)
3058 c            gelc(k,i)=gelc(k,i)+ghalf
3059 c            gelc(k,j)=gelc(k,j)+ghalf
3060 c          enddo
3061 c 9/28/08 AL Gradient compotents will be summed only at the end
3062           do k=1,3
3063             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3064             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3065           enddo
3066 *
3067 * Loop over residues i+1 thru j-1.
3068 *
3069 cgrad          do k=i+1,j-1
3070 cgrad            do l=1,3
3071 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3072 cgrad            enddo
3073 cgrad          enddo
3074           ggg(1)=facvdw*xj
3075           ggg(2)=facvdw*yj
3076           ggg(3)=facvdw*zj
3077 c          do k=1,3
3078 c            ghalf=0.5D0*ggg(k)
3079 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3080 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3081 c          enddo
3082 c 9/28/08 AL Gradient compotents will be summed only at the end
3083           do k=1,3
3084             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3085             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3086           enddo
3087 *
3088 * Loop over residues i+1 thru j-1.
3089 *
3090 cgrad          do k=i+1,j-1
3091 cgrad            do l=1,3
3092 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3093 cgrad            enddo
3094 cgrad          enddo
3095 #else
3096           facvdw=ev1+evdwij
3097           facel=el1+eesij
3098           fac1=fac
3099           fac=-3*rrmij*(facvdw+facvdw+facel)
3100           erij(1)=xj*rmij
3101           erij(2)=yj*rmij
3102           erij(3)=zj*rmij
3103 *
3104 * Radial derivatives. First process both termini of the fragment (i,j)
3105 *
3106           ggg(1)=fac*xj
3107           ggg(2)=fac*yj
3108           ggg(3)=fac*zj
3109 c          do k=1,3
3110 c            ghalf=0.5D0*ggg(k)
3111 c            gelc(k,i)=gelc(k,i)+ghalf
3112 c            gelc(k,j)=gelc(k,j)+ghalf
3113 c          enddo
3114 c 9/28/08 AL Gradient compotents will be summed only at the end
3115           do k=1,3
3116             gelc_long(k,j)=gelc(k,j)+ggg(k)
3117             gelc_long(k,i)=gelc(k,i)-ggg(k)
3118           enddo
3119 *
3120 * Loop over residues i+1 thru j-1.
3121 *
3122 cgrad          do k=i+1,j-1
3123 cgrad            do l=1,3
3124 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3125 cgrad            enddo
3126 cgrad          enddo
3127 c 9/28/08 AL Gradient compotents will be summed only at the end
3128           ggg(1)=facvdw*xj
3129           ggg(2)=facvdw*yj
3130           ggg(3)=facvdw*zj
3131           do k=1,3
3132             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3133             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3134           enddo
3135 #endif
3136 *
3137 * Angular part
3138 *
3139           ecosa=2.0D0*fac3*fac1+fac4
3140           fac4=-3.0D0*fac4
3141           fac3=-6.0D0*fac3
3142           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3143           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3144           do k=1,3
3145             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3146             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3147           enddo
3148 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3149 cd   &          (dcosg(k),k=1,3)
3150           do k=1,3
3151             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3152           enddo
3153 c          do k=1,3
3154 c            ghalf=0.5D0*ggg(k)
3155 c            gelc(k,i)=gelc(k,i)+ghalf
3156 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3157 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3158 c            gelc(k,j)=gelc(k,j)+ghalf
3159 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3160 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3161 c          enddo
3162 cgrad          do k=i+1,j-1
3163 cgrad            do l=1,3
3164 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3165 cgrad            enddo
3166 cgrad          enddo
3167           do k=1,3
3168             gelc(k,i)=gelc(k,i)
3169      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3170      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3171             gelc(k,j)=gelc(k,j)
3172      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3173      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3174             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3175             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3176           enddo
3177           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3178      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3179      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3180 C
3181 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3182 C   energy of a peptide unit is assumed in the form of a second-order
3183 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3184 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3185 C   are computed for EVERY pair of non-contiguous peptide groups.
3186 C
3187
3188           if (j.lt.nres-1) then
3189             j1=j+1
3190             j2=j-1
3191           else
3192             j1=j-1
3193             j2=j-2
3194           endif
3195           kkk=0
3196           lll=0
3197           do k=1,2
3198             do l=1,2
3199               kkk=kkk+1
3200               muij(kkk)=mu(k,i)*mu(l,j)
3201 #ifdef NEWCORR
3202              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3203 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(k,i),k,i
3204              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3205              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3206 c             write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(l,j),l,j
3207              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3208 #endif
3209             enddo
3210           enddo
3211 cd         write (iout,*) 'EELEC: i',i,' j',j
3212 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3213 cd          write(iout,*) 'muij',muij
3214           ury=scalar(uy(1,i),erij)
3215           urz=scalar(uz(1,i),erij)
3216           vry=scalar(uy(1,j),erij)
3217           vrz=scalar(uz(1,j),erij)
3218           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3219           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3220           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3221           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3222           fac=dsqrt(-ael6i)*r3ij
3223           a22=a22*fac
3224           a23=a23*fac
3225           a32=a32*fac
3226           a33=a33*fac
3227 cd          write (iout,'(4i5,4f10.5)')
3228 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3229 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3230 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3231 cd     &      uy(:,j),uz(:,j)
3232 cd          write (iout,'(4f10.5)')
3233 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3234 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3235 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3236 cd           write (iout,'(9f10.5/)')
3237 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3238 C Derivatives of the elements of A in virtual-bond vectors
3239           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3240           do k=1,3
3241             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3242             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3243             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3244             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3245             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3246             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3247             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3248             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3249             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3250             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3251             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3252             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3253           enddo
3254 C Compute radial contributions to the gradient
3255           facr=-3.0d0*rrmij
3256           a22der=a22*facr
3257           a23der=a23*facr
3258           a32der=a32*facr
3259           a33der=a33*facr
3260           agg(1,1)=a22der*xj
3261           agg(2,1)=a22der*yj
3262           agg(3,1)=a22der*zj
3263           agg(1,2)=a23der*xj
3264           agg(2,2)=a23der*yj
3265           agg(3,2)=a23der*zj
3266           agg(1,3)=a32der*xj
3267           agg(2,3)=a32der*yj
3268           agg(3,3)=a32der*zj
3269           agg(1,4)=a33der*xj
3270           agg(2,4)=a33der*yj
3271           agg(3,4)=a33der*zj
3272 C Add the contributions coming from er
3273           fac3=-3.0d0*fac
3274           do k=1,3
3275             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3276             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3277             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3278             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3279           enddo
3280           do k=1,3
3281 C Derivatives in DC(i)
3282 cgrad            ghalf1=0.5d0*agg(k,1)
3283 cgrad            ghalf2=0.5d0*agg(k,2)
3284 cgrad            ghalf3=0.5d0*agg(k,3)
3285 cgrad            ghalf4=0.5d0*agg(k,4)
3286             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3287      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3288             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3289      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3290             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3291      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3292             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3293      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3294 C Derivatives in DC(i+1)
3295             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3296      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3297             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3298      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3299             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3300      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3301             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3302      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3303 C Derivatives in DC(j)
3304             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3305      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3306             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3307      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3308             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3309      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3310             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3311      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3312 C Derivatives in DC(j+1) or DC(nres-1)
3313             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3314      &      -3.0d0*vryg(k,3)*ury)
3315             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3316      &      -3.0d0*vrzg(k,3)*ury)
3317             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3318      &      -3.0d0*vryg(k,3)*urz)
3319             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3320      &      -3.0d0*vrzg(k,3)*urz)
3321 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3322 cgrad              do l=1,4
3323 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3324 cgrad              enddo
3325 cgrad            endif
3326           enddo
3327           acipa(1,1)=a22
3328           acipa(1,2)=a23
3329           acipa(2,1)=a32
3330           acipa(2,2)=a33
3331           a22=-a22
3332           a23=-a23
3333           do l=1,2
3334             do k=1,3
3335               agg(k,l)=-agg(k,l)
3336               aggi(k,l)=-aggi(k,l)
3337               aggi1(k,l)=-aggi1(k,l)
3338               aggj(k,l)=-aggj(k,l)
3339               aggj1(k,l)=-aggj1(k,l)
3340             enddo
3341           enddo
3342           if (j.lt.nres-1) then
3343             a22=-a22
3344             a32=-a32
3345             do l=1,3,2
3346               do k=1,3
3347                 agg(k,l)=-agg(k,l)
3348                 aggi(k,l)=-aggi(k,l)
3349                 aggi1(k,l)=-aggi1(k,l)
3350                 aggj(k,l)=-aggj(k,l)
3351                 aggj1(k,l)=-aggj1(k,l)
3352               enddo
3353             enddo
3354           else
3355             a22=-a22
3356             a23=-a23
3357             a32=-a32
3358             a33=-a33
3359             do l=1,4
3360               do k=1,3
3361                 agg(k,l)=-agg(k,l)
3362                 aggi(k,l)=-aggi(k,l)
3363                 aggi1(k,l)=-aggi1(k,l)
3364                 aggj(k,l)=-aggj(k,l)
3365                 aggj1(k,l)=-aggj1(k,l)
3366               enddo
3367             enddo
3368           endif
3369           ENDIF ! WCORR
3370           IF (wel_loc.gt.0.0d0) THEN
3371 c           if ((i.eq.8).and.(j.eq.14)) then
3372 C Contribution to the local-electrostatic energy coming from the i-j pair
3373           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3374      &     +a33*muij(4)
3375 C Calculate patrial derivative for theta angle
3376 #ifdef NEWCORR
3377          geel_loc_ij=a22*gmuij1(1)
3378      &     +a23*gmuij1(2)
3379      &     +a32*gmuij1(3)
3380      &     +a33*gmuij1(4)
3381 c         write(iout,*) "derivative over thatai"
3382 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3383 c     &   a33*gmuij1(4)
3384          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3385      &      geel_loc_ij*wel_loc
3386 c         write(iout,*) "derivative over thatai-1"
3387 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3388 c     &   a33*gmuij2(4)
3389          geel_loc_ij=a22*gmuij2(1)+a23*gmuij2(2)+a32*gmuij2(3)
3390      &     +a33*gmuij2(4)
3391          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3392      &      geel_loc_ij*wel_loc
3393          geel_loc_ji=a22*gmuji1(1)+a23*gmuji1(2)+a32*gmuji1(3)
3394      &     +a33*gmuji1(4)
3395 c         write(iout,*) "derivative over thataj"
3396 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3397 c     &   a33*gmuji1(4)
3398
3399          gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3400      &      geel_loc_ji*wel_loc
3401          geel_loc_ji=a22*gmuji2(1)+a23*gmuji2(2)+a32*gmuji2(3)
3402      &     +a33*gmuji2(4)
3403 c         write(iout,*) "derivative over thataj-1"
3404 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3405 c     &   a33*gmuji2(4)
3406          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3407      &      geel_loc_ji*wel_loc
3408 #endif
3409 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3410
3411           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3412      &            'eelloc',i,j,eel_loc_ij
3413 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3414
3415           eel_loc=eel_loc+eel_loc_ij
3416 C Partial derivatives in virtual-bond dihedral angles gamma
3417           if (i.gt.1)
3418      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3419      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3420      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3421           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3422      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3423      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3424 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3425           do l=1,3
3426             ggg(l)=agg(l,1)*muij(1)+
3427      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3428             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3429             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3430 cgrad            ghalf=0.5d0*ggg(l)
3431 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3432 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3433           enddo
3434 cgrad          do k=i+1,j2
3435 cgrad            do l=1,3
3436 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3437 cgrad            enddo
3438 cgrad          enddo
3439 C Remaining derivatives of eello
3440           do l=1,3
3441             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3442      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3443             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3444      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3445             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3446      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3447             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3448      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3449           enddo
3450 c          endif
3451           ENDIF
3452 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3453 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3454           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3455      &       .and. num_conti.le.maxconts) then
3456 c            write (iout,*) i,j," entered corr"
3457 C
3458 C Calculate the contact function. The ith column of the array JCONT will
3459 C contain the numbers of atoms that make contacts with the atom I (of numbers
3460 C greater than I). The arrays FACONT and GACONT will contain the values of
3461 C the contact function and its derivative.
3462 c           r0ij=1.02D0*rpp(iteli,itelj)
3463 c           r0ij=1.11D0*rpp(iteli,itelj)
3464             r0ij=2.20D0*rpp(iteli,itelj)
3465 c           r0ij=1.55D0*rpp(iteli,itelj)
3466             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3467             if (fcont.gt.0.0D0) then
3468               num_conti=num_conti+1
3469               if (num_conti.gt.maxconts) then
3470                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3471      &                         ' will skip next contacts for this conf.'
3472               else
3473                 jcont_hb(num_conti,i)=j
3474 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3475 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3476                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3477      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3478 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3479 C  terms.
3480                 d_cont(num_conti,i)=rij
3481 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3482 C     --- Electrostatic-interaction matrix ---
3483                 a_chuj(1,1,num_conti,i)=a22
3484                 a_chuj(1,2,num_conti,i)=a23
3485                 a_chuj(2,1,num_conti,i)=a32
3486                 a_chuj(2,2,num_conti,i)=a33
3487 C     --- Gradient of rij
3488                 do kkk=1,3
3489                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3490                 enddo
3491                 kkll=0
3492                 do k=1,2
3493                   do l=1,2
3494                     kkll=kkll+1
3495                     do m=1,3
3496                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3497                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3498                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3499                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3500                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3501                     enddo
3502                   enddo
3503                 enddo
3504                 ENDIF
3505                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3506 C Calculate contact energies
3507                 cosa4=4.0D0*cosa
3508                 wij=cosa-3.0D0*cosb*cosg
3509                 cosbg1=cosb+cosg
3510                 cosbg2=cosb-cosg
3511 c               fac3=dsqrt(-ael6i)/r0ij**3
3512                 fac3=dsqrt(-ael6i)*r3ij
3513 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3514                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3515                 if (ees0tmp.gt.0) then
3516                   ees0pij=dsqrt(ees0tmp)
3517                 else
3518                   ees0pij=0
3519                 endif
3520 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3521                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3522                 if (ees0tmp.gt.0) then
3523                   ees0mij=dsqrt(ees0tmp)
3524                 else
3525                   ees0mij=0
3526                 endif
3527 c               ees0mij=0.0D0
3528                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3529                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3530 C Diagnostics. Comment out or remove after debugging!
3531 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3532 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3533 c               ees0m(num_conti,i)=0.0D0
3534 C End diagnostics.
3535 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3536 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3537 C Angular derivatives of the contact function
3538                 ees0pij1=fac3/ees0pij
3539                 ees0mij1=fac3/ees0mij
3540                 fac3p=-3.0D0*fac3*rrmij
3541                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3542                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3543 c               ees0mij1=0.0D0
3544                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3545                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3546                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3547                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3548                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3549                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3550                 ecosap=ecosa1+ecosa2
3551                 ecosbp=ecosb1+ecosb2
3552                 ecosgp=ecosg1+ecosg2
3553                 ecosam=ecosa1-ecosa2
3554                 ecosbm=ecosb1-ecosb2
3555                 ecosgm=ecosg1-ecosg2
3556 C Diagnostics
3557 c               ecosap=ecosa1
3558 c               ecosbp=ecosb1
3559 c               ecosgp=ecosg1
3560 c               ecosam=0.0D0
3561 c               ecosbm=0.0D0
3562 c               ecosgm=0.0D0
3563 C End diagnostics
3564                 facont_hb(num_conti,i)=fcont
3565                 fprimcont=fprimcont/rij
3566 cd              facont_hb(num_conti,i)=1.0D0
3567 C Following line is for diagnostics.
3568 cd              fprimcont=0.0D0
3569                 do k=1,3
3570                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3571                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3572                 enddo
3573                 do k=1,3
3574                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3575                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3576                 enddo
3577                 gggp(1)=gggp(1)+ees0pijp*xj
3578                 gggp(2)=gggp(2)+ees0pijp*yj
3579                 gggp(3)=gggp(3)+ees0pijp*zj
3580                 gggm(1)=gggm(1)+ees0mijp*xj
3581                 gggm(2)=gggm(2)+ees0mijp*yj
3582                 gggm(3)=gggm(3)+ees0mijp*zj
3583 C Derivatives due to the contact function
3584                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3585                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3586                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3587                 do k=1,3
3588 c
3589 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3590 c          following the change of gradient-summation algorithm.
3591 c
3592 cgrad                  ghalfp=0.5D0*gggp(k)
3593 cgrad                  ghalfm=0.5D0*gggm(k)
3594                   gacontp_hb1(k,num_conti,i)=!ghalfp
3595      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3596      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3597                   gacontp_hb2(k,num_conti,i)=!ghalfp
3598      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3599      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3600                   gacontp_hb3(k,num_conti,i)=gggp(k)
3601                   gacontm_hb1(k,num_conti,i)=!ghalfm
3602      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3603      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3604                   gacontm_hb2(k,num_conti,i)=!ghalfm
3605      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3606      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3607                   gacontm_hb3(k,num_conti,i)=gggm(k)
3608                 enddo
3609 C Diagnostics. Comment out or remove after debugging!
3610 cdiag           do k=1,3
3611 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3612 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3613 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3614 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3615 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3616 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3617 cdiag           enddo
3618               ENDIF ! wcorr
3619               endif  ! num_conti.le.maxconts
3620             endif  ! fcont.gt.0
3621           endif    ! j.gt.i+1
3622           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3623             do k=1,4
3624               do l=1,3
3625                 ghalf=0.5d0*agg(l,k)
3626                 aggi(l,k)=aggi(l,k)+ghalf
3627                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3628                 aggj(l,k)=aggj(l,k)+ghalf
3629               enddo
3630             enddo
3631             if (j.eq.nres-1 .and. i.lt.j-2) then
3632               do k=1,4
3633                 do l=1,3
3634                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3635                 enddo
3636               enddo
3637             endif
3638           endif
3639 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3640       return
3641       end
3642 C-----------------------------------------------------------------------------
3643       subroutine eturn3(i,eello_turn3)
3644 C Third- and fourth-order contributions from turns
3645       implicit real*8 (a-h,o-z)
3646       include 'DIMENSIONS'
3647       include 'COMMON.IOUNITS'
3648       include 'COMMON.GEO'
3649       include 'COMMON.VAR'
3650       include 'COMMON.LOCAL'
3651       include 'COMMON.CHAIN'
3652       include 'COMMON.DERIV'
3653       include 'COMMON.INTERACT'
3654       include 'COMMON.CONTACTS'
3655       include 'COMMON.TORSION'
3656       include 'COMMON.VECTORS'
3657       include 'COMMON.FFIELD'
3658       include 'COMMON.CONTROL'
3659       dimension ggg(3)
3660       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3661      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3662      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3663      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3664      &  auxgmat2(2,2),auxgmatt2(2,2)
3665       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3666      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3667       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3668      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3669      &    num_conti,j1,j2
3670       j=i+2
3671 c      write (iout,*) "eturn3",i,j,j1,j2
3672       a_temp(1,1)=a22
3673       a_temp(1,2)=a23
3674       a_temp(2,1)=a32
3675       a_temp(2,2)=a33
3676 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3677 C
3678 C               Third-order contributions
3679 C
3680 C                 (i+2)o----(i+3)
3681 C                      | |
3682 C                      | |
3683 C                 (i+1)o----i
3684 C
3685 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3686 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3687         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3688 c auxalary matices for theta gradient
3689 c auxalary matrix for i+1 and constant i+2
3690         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3691 c auxalary matrix for i+2 and constant i+1
3692         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3693         call transpose2(auxmat(1,1),auxmat1(1,1))
3694         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3695         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3696         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3697         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3698         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3699         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3700 C Derivatives in theta
3701         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3702      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3703         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3704      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3705
3706         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3707      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3708 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3709 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3710 cd     &    ' eello_turn3_num',4*eello_turn3_num
3711 C Derivatives in gamma(i)
3712         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3713         call transpose2(auxmat2(1,1),auxmat3(1,1))
3714         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3715         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3716 C Derivatives in gamma(i+1)
3717         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3718         call transpose2(auxmat2(1,1),auxmat3(1,1))
3719         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3720         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3721      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3722 C Cartesian derivatives
3723         do l=1,3
3724 c            ghalf1=0.5d0*agg(l,1)
3725 c            ghalf2=0.5d0*agg(l,2)
3726 c            ghalf3=0.5d0*agg(l,3)
3727 c            ghalf4=0.5d0*agg(l,4)
3728           a_temp(1,1)=aggi(l,1)!+ghalf1
3729           a_temp(1,2)=aggi(l,2)!+ghalf2
3730           a_temp(2,1)=aggi(l,3)!+ghalf3
3731           a_temp(2,2)=aggi(l,4)!+ghalf4
3732           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3733           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3734      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3735           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3736           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3737           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3738           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3739           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3740           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3741      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3742           a_temp(1,1)=aggj(l,1)!+ghalf1
3743           a_temp(1,2)=aggj(l,2)!+ghalf2
3744           a_temp(2,1)=aggj(l,3)!+ghalf3
3745           a_temp(2,2)=aggj(l,4)!+ghalf4
3746           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3747           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3748      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3749           a_temp(1,1)=aggj1(l,1)
3750           a_temp(1,2)=aggj1(l,2)
3751           a_temp(2,1)=aggj1(l,3)
3752           a_temp(2,2)=aggj1(l,4)
3753           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3754           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3755      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3756         enddo
3757       return
3758       end
3759 C-------------------------------------------------------------------------------
3760       subroutine eturn4(i,eello_turn4)
3761 C Third- and fourth-order contributions from turns
3762       implicit real*8 (a-h,o-z)
3763       include 'DIMENSIONS'
3764       include 'COMMON.IOUNITS'
3765       include 'COMMON.GEO'
3766       include 'COMMON.VAR'
3767       include 'COMMON.LOCAL'
3768       include 'COMMON.CHAIN'
3769       include 'COMMON.DERIV'
3770       include 'COMMON.INTERACT'
3771       include 'COMMON.CONTACTS'
3772       include 'COMMON.TORSION'
3773       include 'COMMON.VECTORS'
3774       include 'COMMON.FFIELD'
3775       include 'COMMON.CONTROL'
3776       dimension ggg(3)
3777       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3778      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3779      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3780      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3781      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3782      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3783      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3784       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3785      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3786       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3787      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3788      &    num_conti,j1,j2
3789       j=i+3
3790 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3791 C
3792 C               Fourth-order contributions
3793 C
3794 C                 (i+3)o----(i+4)
3795 C                     /  |
3796 C               (i+2)o   |
3797 C                     \  |
3798 C                 (i+1)o----i
3799 C
3800 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3801 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3802 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3803 c        write(iout,*)"WCHODZE W PROGRAM"
3804         a_temp(1,1)=a22
3805         a_temp(1,2)=a23
3806         a_temp(2,1)=a32
3807         a_temp(2,2)=a33
3808         iti1=itortyp(itype(i+1))
3809         iti2=itortyp(itype(i+2))
3810         iti3=itortyp(itype(i+3))
3811 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3812         call transpose2(EUg(1,1,i+1),e1t(1,1))
3813         call transpose2(Eug(1,1,i+2),e2t(1,1))
3814         call transpose2(Eug(1,1,i+3),e3t(1,1))
3815 C Ematrix derivative in theta
3816         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3817         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3818         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3819         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3820 c       eta1 in derivative theta
3821         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3822         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3823 c       auxgvec is derivative of Ub2 so i+3 theta
3824         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3825 c       auxalary matrix of E i+1
3826         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3827 c        s1=0.0
3828 c        gs1=0.0
3829         s1=scalar2(b1(1,i+2),auxvec(1))
3830 c derivative of theta i+2 with constant i+3
3831         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3832 c derivative of theta i+2 with constant i+2
3833         gs32=scalar2(b1(1,i+2),auxgvec(1))
3834 c derivative of E matix in theta of i+1
3835         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3836
3837         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3838 c       ea31 in derivative theta
3839         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3840         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3841 c auxilary matrix auxgvec of Ub2 with constant E matirx
3842         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3843 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3844         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3845
3846 c        s2=0.0
3847 c        gs2=0.0
3848         s2=scalar2(b1(1,i+1),auxvec(1))
3849 c derivative of theta i+1 with constant i+3
3850         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3851 c derivative of theta i+2 with constant i+1
3852         gs21=scalar2(b1(1,i+1),auxgvec(1))
3853 c derivative of theta i+3 with constant i+1
3854         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3855 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3856 c     &  gtb1(1,i+1)
3857         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3858 c two derivatives over diffetent matrices
3859 c gtae3e2 is derivative over i+3
3860         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3861 c ae3gte2 is derivative over i+2
3862         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3863         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3864 c three possible derivative over theta E matices
3865 c i+1
3866         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3867 c i+2
3868         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3869 c i+3
3870         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3871         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3872
3873         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3874         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3875         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3876
3877         eello_turn4=eello_turn4-(s1+s2+s3)
3878 #ifdef NEWCORR
3879         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3880      &                  -(gs13+gsE13+gsEE1)*wturn4
3881         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3882      &                    -(gs23+gs21+gsEE2)*wturn4
3883         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3884      &                    -(gs32+gsE31+gsEE3)*wturn4
3885 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3886 c     &   gs2
3887 #endif
3888         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3889      &      'eturn4',i,j,-(s1+s2+s3)
3890 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3891 c     &    ' eello_turn4_num',8*eello_turn4_num
3892 C Derivatives in gamma(i)
3893         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3894         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3895         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3896         s1=scalar2(b1(1,i+2),auxvec(1))
3897         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3898         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3899         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3900 C Derivatives in gamma(i+1)
3901         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3902         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3903         s2=scalar2(b1(1,i+1),auxvec(1))
3904         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3905         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3906         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3907         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3908 C Derivatives in gamma(i+2)
3909         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3910         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3911         s1=scalar2(b1(1,i+2),auxvec(1))
3912         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3913         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3914         s2=scalar2(b1(1,i+1),auxvec(1))
3915         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3916         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3917         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3918         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3919 C Cartesian derivatives
3920 C Derivatives of this turn contributions in DC(i+2)
3921         if (j.lt.nres-1) then
3922           do l=1,3
3923             a_temp(1,1)=agg(l,1)
3924             a_temp(1,2)=agg(l,2)
3925             a_temp(2,1)=agg(l,3)
3926             a_temp(2,2)=agg(l,4)
3927             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3928             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3929             s1=scalar2(b1(1,i+2),auxvec(1))
3930             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3931             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3932             s2=scalar2(b1(1,i+1),auxvec(1))
3933             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3934             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3935             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3936             ggg(l)=-(s1+s2+s3)
3937             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3938           enddo
3939         endif
3940 C Remaining derivatives of this turn contribution
3941         do l=1,3
3942           a_temp(1,1)=aggi(l,1)
3943           a_temp(1,2)=aggi(l,2)
3944           a_temp(2,1)=aggi(l,3)
3945           a_temp(2,2)=aggi(l,4)
3946           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3947           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3948           s1=scalar2(b1(1,i+2),auxvec(1))
3949           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3950           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3951           s2=scalar2(b1(1,i+1),auxvec(1))
3952           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3953           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3954           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3955           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3956           a_temp(1,1)=aggi1(l,1)
3957           a_temp(1,2)=aggi1(l,2)
3958           a_temp(2,1)=aggi1(l,3)
3959           a_temp(2,2)=aggi1(l,4)
3960           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3961           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3962           s1=scalar2(b1(1,i+2),auxvec(1))
3963           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3964           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3965           s2=scalar2(b1(1,i+1),auxvec(1))
3966           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3967           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3968           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3969           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3970           a_temp(1,1)=aggj(l,1)
3971           a_temp(1,2)=aggj(l,2)
3972           a_temp(2,1)=aggj(l,3)
3973           a_temp(2,2)=aggj(l,4)
3974           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3975           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3976           s1=scalar2(b1(1,i+2),auxvec(1))
3977           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3978           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3979           s2=scalar2(b1(1,i+1),auxvec(1))
3980           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3981           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3982           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3983           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3984           a_temp(1,1)=aggj1(l,1)
3985           a_temp(1,2)=aggj1(l,2)
3986           a_temp(2,1)=aggj1(l,3)
3987           a_temp(2,2)=aggj1(l,4)
3988           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3989           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3990           s1=scalar2(b1(1,i+2),auxvec(1))
3991           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3992           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3993           s2=scalar2(b1(1,i+1),auxvec(1))
3994           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3995           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3996           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3997 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3998           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3999         enddo
4000       return
4001       end
4002 C-----------------------------------------------------------------------------
4003       subroutine vecpr(u,v,w)
4004       implicit real*8(a-h,o-z)
4005       dimension u(3),v(3),w(3)
4006       w(1)=u(2)*v(3)-u(3)*v(2)
4007       w(2)=-u(1)*v(3)+u(3)*v(1)
4008       w(3)=u(1)*v(2)-u(2)*v(1)
4009       return
4010       end
4011 C-----------------------------------------------------------------------------
4012       subroutine unormderiv(u,ugrad,unorm,ungrad)
4013 C This subroutine computes the derivatives of a normalized vector u, given
4014 C the derivatives computed without normalization conditions, ugrad. Returns
4015 C ungrad.
4016       implicit none
4017       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4018       double precision vec(3)
4019       double precision scalar
4020       integer i,j
4021 c      write (2,*) 'ugrad',ugrad
4022 c      write (2,*) 'u',u
4023       do i=1,3
4024         vec(i)=scalar(ugrad(1,i),u(1))
4025       enddo
4026 c      write (2,*) 'vec',vec
4027       do i=1,3
4028         do j=1,3
4029           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4030         enddo
4031       enddo
4032 c      write (2,*) 'ungrad',ungrad
4033       return
4034       end
4035 C-----------------------------------------------------------------------------
4036       subroutine escp_soft_sphere(evdw2,evdw2_14)
4037 C
4038 C This subroutine calculates the excluded-volume interaction energy between
4039 C peptide-group centers and side chains and its gradient in virtual-bond and
4040 C side-chain vectors.
4041 C
4042       implicit real*8 (a-h,o-z)
4043       include 'DIMENSIONS'
4044       include 'COMMON.GEO'
4045       include 'COMMON.VAR'
4046       include 'COMMON.LOCAL'
4047       include 'COMMON.CHAIN'
4048       include 'COMMON.DERIV'
4049       include 'COMMON.INTERACT'
4050       include 'COMMON.FFIELD'
4051       include 'COMMON.IOUNITS'
4052       include 'COMMON.CONTROL'
4053       dimension ggg(3)
4054       evdw2=0.0D0
4055       evdw2_14=0.0d0
4056       r0_scp=4.5d0
4057 cd    print '(a)','Enter ESCP'
4058 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4059       do i=iatscp_s,iatscp_e
4060         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4061         iteli=itel(i)
4062         xi=0.5D0*(c(1,i)+c(1,i+1))
4063         yi=0.5D0*(c(2,i)+c(2,i+1))
4064         zi=0.5D0*(c(3,i)+c(3,i+1))
4065
4066         do iint=1,nscp_gr(i)
4067
4068         do j=iscpstart(i,iint),iscpend(i,iint)
4069           if (itype(j).eq.ntyp1) cycle
4070           itypj=iabs(itype(j))
4071 C Uncomment following three lines for SC-p interactions
4072 c         xj=c(1,nres+j)-xi
4073 c         yj=c(2,nres+j)-yi
4074 c         zj=c(3,nres+j)-zi
4075 C Uncomment following three lines for Ca-p interactions
4076           xj=c(1,j)-xi
4077           yj=c(2,j)-yi
4078           zj=c(3,j)-zi
4079           rij=xj*xj+yj*yj+zj*zj
4080           r0ij=r0_scp
4081           r0ijsq=r0ij*r0ij
4082           if (rij.lt.r0ijsq) then
4083             evdwij=0.25d0*(rij-r0ijsq)**2
4084             fac=rij-r0ijsq
4085           else
4086             evdwij=0.0d0
4087             fac=0.0d0
4088           endif
4089           evdw2=evdw2+evdwij
4090 C
4091 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4092 C
4093           ggg(1)=xj*fac
4094           ggg(2)=yj*fac
4095           ggg(3)=zj*fac
4096 cgrad          if (j.lt.i) then
4097 cd          write (iout,*) 'j<i'
4098 C Uncomment following three lines for SC-p interactions
4099 c           do k=1,3
4100 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4101 c           enddo
4102 cgrad          else
4103 cd          write (iout,*) 'j>i'
4104 cgrad            do k=1,3
4105 cgrad              ggg(k)=-ggg(k)
4106 C Uncomment following line for SC-p interactions
4107 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4108 cgrad            enddo
4109 cgrad          endif
4110 cgrad          do k=1,3
4111 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4112 cgrad          enddo
4113 cgrad          kstart=min0(i+1,j)
4114 cgrad          kend=max0(i-1,j-1)
4115 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4116 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4117 cgrad          do k=kstart,kend
4118 cgrad            do l=1,3
4119 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4120 cgrad            enddo
4121 cgrad          enddo
4122           do k=1,3
4123             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4124             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4125           enddo
4126         enddo
4127
4128         enddo ! iint
4129       enddo ! i
4130       return
4131       end
4132 C-----------------------------------------------------------------------------
4133       subroutine escp(evdw2,evdw2_14)
4134 C
4135 C This subroutine calculates the excluded-volume interaction energy between
4136 C peptide-group centers and side chains and its gradient in virtual-bond and
4137 C side-chain vectors.
4138 C
4139       implicit real*8 (a-h,o-z)
4140       include 'DIMENSIONS'
4141       include 'COMMON.GEO'
4142       include 'COMMON.VAR'
4143       include 'COMMON.LOCAL'
4144       include 'COMMON.CHAIN'
4145       include 'COMMON.DERIV'
4146       include 'COMMON.INTERACT'
4147       include 'COMMON.FFIELD'
4148       include 'COMMON.IOUNITS'
4149       include 'COMMON.CONTROL'
4150       dimension ggg(3)
4151       evdw2=0.0D0
4152       evdw2_14=0.0d0
4153 cd    print '(a)','Enter ESCP'
4154 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4155       do i=iatscp_s,iatscp_e
4156         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4157         iteli=itel(i)
4158         xi=0.5D0*(c(1,i)+c(1,i+1))
4159         yi=0.5D0*(c(2,i)+c(2,i+1))
4160         zi=0.5D0*(c(3,i)+c(3,i+1))
4161
4162         do iint=1,nscp_gr(i)
4163
4164         do j=iscpstart(i,iint),iscpend(i,iint)
4165           itypj=iabs(itype(j))
4166           if (itypj.eq.ntyp1) cycle
4167 C Uncomment following three lines for SC-p interactions
4168 c         xj=c(1,nres+j)-xi
4169 c         yj=c(2,nres+j)-yi
4170 c         zj=c(3,nres+j)-zi
4171 C Uncomment following three lines for Ca-p interactions
4172           xj=c(1,j)-xi
4173           yj=c(2,j)-yi
4174           zj=c(3,j)-zi
4175           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4176           fac=rrij**expon2
4177           e1=fac*fac*aad(itypj,iteli)
4178           e2=fac*bad(itypj,iteli)
4179           if (iabs(j-i) .le. 2) then
4180             e1=scal14*e1
4181             e2=scal14*e2
4182             evdw2_14=evdw2_14+e1+e2
4183           endif
4184           evdwij=e1+e2
4185           evdw2=evdw2+evdwij
4186           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4187      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4188      &       bad(itypj,iteli)
4189 C
4190 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4191 C
4192           fac=-(evdwij+e1)*rrij
4193           ggg(1)=xj*fac
4194           ggg(2)=yj*fac
4195           ggg(3)=zj*fac
4196 cgrad          if (j.lt.i) then
4197 cd          write (iout,*) 'j<i'
4198 C Uncomment following three lines for SC-p interactions
4199 c           do k=1,3
4200 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4201 c           enddo
4202 cgrad          else
4203 cd          write (iout,*) 'j>i'
4204 cgrad            do k=1,3
4205 cgrad              ggg(k)=-ggg(k)
4206 C Uncomment following line for SC-p interactions
4207 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4208 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4209 cgrad            enddo
4210 cgrad          endif
4211 cgrad          do k=1,3
4212 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4213 cgrad          enddo
4214 cgrad          kstart=min0(i+1,j)
4215 cgrad          kend=max0(i-1,j-1)
4216 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4217 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4218 cgrad          do k=kstart,kend
4219 cgrad            do l=1,3
4220 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4221 cgrad            enddo
4222 cgrad          enddo
4223           do k=1,3
4224             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4225             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4226           enddo
4227         enddo
4228
4229         enddo ! iint
4230       enddo ! i
4231       do i=1,nct
4232         do j=1,3
4233           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4234           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4235           gradx_scp(j,i)=expon*gradx_scp(j,i)
4236         enddo
4237       enddo
4238 C******************************************************************************
4239 C
4240 C                              N O T E !!!
4241 C
4242 C To save time the factor EXPON has been extracted from ALL components
4243 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4244 C use!
4245 C
4246 C******************************************************************************
4247       return
4248       end
4249 C--------------------------------------------------------------------------
4250       subroutine edis(ehpb)
4251 C
4252 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4253 C
4254       implicit real*8 (a-h,o-z)
4255       include 'DIMENSIONS'
4256       include 'COMMON.SBRIDGE'
4257       include 'COMMON.CHAIN'
4258       include 'COMMON.DERIV'
4259       include 'COMMON.VAR'
4260       include 'COMMON.INTERACT'
4261       include 'COMMON.IOUNITS'
4262       dimension ggg(3)
4263       ehpb=0.0D0
4264 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4265 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4266       if (link_end.eq.0) return
4267       do i=link_start,link_end
4268 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4269 C CA-CA distance used in regularization of structure.
4270         ii=ihpb(i)
4271         jj=jhpb(i)
4272 C iii and jjj point to the residues for which the distance is assigned.
4273         if (ii.gt.nres) then
4274           iii=ii-nres
4275           jjj=jj-nres
4276         else
4277           iii=ii
4278           jjj=jj
4279         endif
4280 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4281 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4282 C    distance and angle dependent SS bond potential.
4283         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4284      & iabs(itype(jjj)).eq.1) then
4285           call ssbond_ene(iii,jjj,eij)
4286           ehpb=ehpb+2*eij
4287 cd          write (iout,*) "eij",eij
4288         else
4289 C Calculate the distance between the two points and its difference from the
4290 C target distance.
4291         dd=dist(ii,jj)
4292         rdis=dd-dhpb(i)
4293 C Get the force constant corresponding to this distance.
4294         waga=forcon(i)
4295 C Calculate the contribution to energy.
4296         ehpb=ehpb+waga*rdis*rdis
4297 C
4298 C Evaluate gradient.
4299 C
4300         fac=waga*rdis/dd
4301 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4302 cd   &   ' waga=',waga,' fac=',fac
4303         do j=1,3
4304           ggg(j)=fac*(c(j,jj)-c(j,ii))
4305         enddo
4306 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4307 C If this is a SC-SC distance, we need to calculate the contributions to the
4308 C Cartesian gradient in the SC vectors (ghpbx).
4309         if (iii.lt.ii) then
4310           do j=1,3
4311             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4312             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4313           enddo
4314         endif
4315 cgrad        do j=iii,jjj-1
4316 cgrad          do k=1,3
4317 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4318 cgrad          enddo
4319 cgrad        enddo
4320         do k=1,3
4321           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4322           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4323         enddo
4324         endif
4325       enddo
4326       ehpb=0.5D0*ehpb
4327       return
4328       end
4329 C--------------------------------------------------------------------------
4330       subroutine ssbond_ene(i,j,eij)
4331 C
4332 C Calculate the distance and angle dependent SS-bond potential energy
4333 C using a free-energy function derived based on RHF/6-31G** ab initio
4334 C calculations of diethyl disulfide.
4335 C
4336 C A. Liwo and U. Kozlowska, 11/24/03
4337 C
4338       implicit real*8 (a-h,o-z)
4339       include 'DIMENSIONS'
4340       include 'COMMON.SBRIDGE'
4341       include 'COMMON.CHAIN'
4342       include 'COMMON.DERIV'
4343       include 'COMMON.LOCAL'
4344       include 'COMMON.INTERACT'
4345       include 'COMMON.VAR'
4346       include 'COMMON.IOUNITS'
4347       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4348       itypi=iabs(itype(i))
4349       xi=c(1,nres+i)
4350       yi=c(2,nres+i)
4351       zi=c(3,nres+i)
4352       dxi=dc_norm(1,nres+i)
4353       dyi=dc_norm(2,nres+i)
4354       dzi=dc_norm(3,nres+i)
4355 c      dsci_inv=dsc_inv(itypi)
4356       dsci_inv=vbld_inv(nres+i)
4357       itypj=iabs(itype(j))
4358 c      dscj_inv=dsc_inv(itypj)
4359       dscj_inv=vbld_inv(nres+j)
4360       xj=c(1,nres+j)-xi
4361       yj=c(2,nres+j)-yi
4362       zj=c(3,nres+j)-zi
4363       dxj=dc_norm(1,nres+j)
4364       dyj=dc_norm(2,nres+j)
4365       dzj=dc_norm(3,nres+j)
4366       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4367       rij=dsqrt(rrij)
4368       erij(1)=xj*rij
4369       erij(2)=yj*rij
4370       erij(3)=zj*rij
4371       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4372       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4373       om12=dxi*dxj+dyi*dyj+dzi*dzj
4374       do k=1,3
4375         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4376         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4377       enddo
4378       rij=1.0d0/rij
4379       deltad=rij-d0cm
4380       deltat1=1.0d0-om1
4381       deltat2=1.0d0+om2
4382       deltat12=om2-om1+2.0d0
4383       cosphi=om12-om1*om2
4384       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4385      &  +akct*deltad*deltat12
4386      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4387 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4388 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4389 c     &  " deltat12",deltat12," eij",eij
4390       ed=2*akcm*deltad+akct*deltat12
4391       pom1=akct*deltad
4392       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4393       eom1=-2*akth*deltat1-pom1-om2*pom2
4394       eom2= 2*akth*deltat2+pom1-om1*pom2
4395       eom12=pom2
4396       do k=1,3
4397         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4398         ghpbx(k,i)=ghpbx(k,i)-ggk
4399      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4400      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4401         ghpbx(k,j)=ghpbx(k,j)+ggk
4402      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4403      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4404         ghpbc(k,i)=ghpbc(k,i)-ggk
4405         ghpbc(k,j)=ghpbc(k,j)+ggk
4406       enddo
4407 C
4408 C Calculate the components of the gradient in DC and X
4409 C
4410 cgrad      do k=i,j-1
4411 cgrad        do l=1,3
4412 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4413 cgrad        enddo
4414 cgrad      enddo
4415       return
4416       end
4417 C--------------------------------------------------------------------------
4418       subroutine ebond(estr)
4419 c
4420 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4421 c
4422       implicit real*8 (a-h,o-z)
4423       include 'DIMENSIONS'
4424       include 'COMMON.LOCAL'
4425       include 'COMMON.GEO'
4426       include 'COMMON.INTERACT'
4427       include 'COMMON.DERIV'
4428       include 'COMMON.VAR'
4429       include 'COMMON.CHAIN'
4430       include 'COMMON.IOUNITS'
4431       include 'COMMON.NAMES'
4432       include 'COMMON.FFIELD'
4433       include 'COMMON.CONTROL'
4434       include 'COMMON.SETUP'
4435       double precision u(3),ud(3)
4436       estr=0.0d0
4437       estr1=0.0d0
4438       do i=ibondp_start,ibondp_end
4439         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4440           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4441           do j=1,3
4442           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4443      &      *dc(j,i-1)/vbld(i)
4444           enddo
4445           if (energy_dec) write(iout,*)
4446      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4447         else
4448         diff = vbld(i)-vbldp0
4449         if (energy_dec) write (iout,*)
4450      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4451         estr=estr+diff*diff
4452         do j=1,3
4453           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4454         enddo
4455 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4456         endif
4457       enddo
4458       estr=0.5d0*AKP*estr+estr1
4459 c
4460 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4461 c
4462       do i=ibond_start,ibond_end
4463         iti=iabs(itype(i))
4464         if (iti.ne.10 .and. iti.ne.ntyp1) then
4465           nbi=nbondterm(iti)
4466           if (nbi.eq.1) then
4467             diff=vbld(i+nres)-vbldsc0(1,iti)
4468             if (energy_dec) write (iout,*)
4469      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4470      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4471             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4472             do j=1,3
4473               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4474             enddo
4475           else
4476             do j=1,nbi
4477               diff=vbld(i+nres)-vbldsc0(j,iti)
4478               ud(j)=aksc(j,iti)*diff
4479               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4480             enddo
4481             uprod=u(1)
4482             do j=2,nbi
4483               uprod=uprod*u(j)
4484             enddo
4485             usum=0.0d0
4486             usumsqder=0.0d0
4487             do j=1,nbi
4488               uprod1=1.0d0
4489               uprod2=1.0d0
4490               do k=1,nbi
4491                 if (k.ne.j) then
4492                   uprod1=uprod1*u(k)
4493                   uprod2=uprod2*u(k)*u(k)
4494                 endif
4495               enddo
4496               usum=usum+uprod1
4497               usumsqder=usumsqder+ud(j)*uprod2
4498             enddo
4499             estr=estr+uprod/usum
4500             do j=1,3
4501              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4502             enddo
4503           endif
4504         endif
4505       enddo
4506       return
4507       end
4508 #ifdef CRYST_THETA
4509 C--------------------------------------------------------------------------
4510       subroutine ebend(etheta)
4511 C
4512 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4513 C angles gamma and its derivatives in consecutive thetas and gammas.
4514 C
4515       implicit real*8 (a-h,o-z)
4516       include 'DIMENSIONS'
4517       include 'COMMON.LOCAL'
4518       include 'COMMON.GEO'
4519       include 'COMMON.INTERACT'
4520       include 'COMMON.DERIV'
4521       include 'COMMON.VAR'
4522       include 'COMMON.CHAIN'
4523       include 'COMMON.IOUNITS'
4524       include 'COMMON.NAMES'
4525       include 'COMMON.FFIELD'
4526       include 'COMMON.CONTROL'
4527       common /calcthet/ term1,term2,termm,diffak,ratak,
4528      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4529      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4530       double precision y(2),z(2)
4531       delta=0.02d0*pi
4532 c      time11=dexp(-2*time)
4533 c      time12=1.0d0
4534       etheta=0.0D0
4535 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4536       do i=ithet_start,ithet_end
4537         if (itype(i-1).eq.ntyp1) cycle
4538 C Zero the energy function and its derivative at 0 or pi.
4539         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4540         it=itype(i-1)
4541         ichir1=isign(1,itype(i-2))
4542         ichir2=isign(1,itype(i))
4543          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4544          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4545          if (itype(i-1).eq.10) then
4546           itype1=isign(10,itype(i-2))
4547           ichir11=isign(1,itype(i-2))
4548           ichir12=isign(1,itype(i-2))
4549           itype2=isign(10,itype(i))
4550           ichir21=isign(1,itype(i))
4551           ichir22=isign(1,itype(i))
4552          endif
4553
4554         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4555 #ifdef OSF
4556           phii=phi(i)
4557           if (phii.ne.phii) phii=150.0
4558 #else
4559           phii=phi(i)
4560 #endif
4561           y(1)=dcos(phii)
4562           y(2)=dsin(phii)
4563         else
4564           y(1)=0.0D0
4565           y(2)=0.0D0
4566         endif
4567         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4568 #ifdef OSF
4569           phii1=phi(i+1)
4570           if (phii1.ne.phii1) phii1=150.0
4571           phii1=pinorm(phii1)
4572           z(1)=cos(phii1)
4573 #else
4574           phii1=phi(i+1)
4575           z(1)=dcos(phii1)
4576 #endif
4577           z(2)=dsin(phii1)
4578         else
4579           z(1)=0.0D0
4580           z(2)=0.0D0
4581         endif
4582 C Calculate the "mean" value of theta from the part of the distribution
4583 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4584 C In following comments this theta will be referred to as t_c.
4585         thet_pred_mean=0.0d0
4586         do k=1,2
4587             athetk=athet(k,it,ichir1,ichir2)
4588             bthetk=bthet(k,it,ichir1,ichir2)
4589           if (it.eq.10) then
4590              athetk=athet(k,itype1,ichir11,ichir12)
4591              bthetk=bthet(k,itype2,ichir21,ichir22)
4592           endif
4593          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4594         enddo
4595         dthett=thet_pred_mean*ssd
4596         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4597 C Derivatives of the "mean" values in gamma1 and gamma2.
4598         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4599      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4600          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4601      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4602          if (it.eq.10) then
4603       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4604      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4605         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4606      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4607          endif
4608         if (theta(i).gt.pi-delta) then
4609           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4610      &         E_tc0)
4611           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4612           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4613           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4614      &        E_theta)
4615           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4616      &        E_tc)
4617         else if (theta(i).lt.delta) then
4618           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4619           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4620           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4621      &        E_theta)
4622           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4623           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4624      &        E_tc)
4625         else
4626           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4627      &        E_theta,E_tc)
4628         endif
4629         etheta=etheta+ethetai
4630         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4631      &      'ebend',i,ethetai
4632         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4633         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4634         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4635       enddo
4636 C Ufff.... We've done all this!!!
4637       return
4638       end
4639 C---------------------------------------------------------------------------
4640       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4641      &     E_tc)
4642       implicit real*8 (a-h,o-z)
4643       include 'DIMENSIONS'
4644       include 'COMMON.LOCAL'
4645       include 'COMMON.IOUNITS'
4646       common /calcthet/ term1,term2,termm,diffak,ratak,
4647      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4648      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4649 C Calculate the contributions to both Gaussian lobes.
4650 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4651 C The "polynomial part" of the "standard deviation" of this part of
4652 C the distribution.
4653         sig=polthet(3,it)
4654         do j=2,0,-1
4655           sig=sig*thet_pred_mean+polthet(j,it)
4656         enddo
4657 C Derivative of the "interior part" of the "standard deviation of the"
4658 C gamma-dependent Gaussian lobe in t_c.
4659         sigtc=3*polthet(3,it)
4660         do j=2,1,-1
4661           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4662         enddo
4663         sigtc=sig*sigtc
4664 C Set the parameters of both Gaussian lobes of the distribution.
4665 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4666         fac=sig*sig+sigc0(it)
4667         sigcsq=fac+fac
4668         sigc=1.0D0/sigcsq
4669 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4670         sigsqtc=-4.0D0*sigcsq*sigtc
4671 c       print *,i,sig,sigtc,sigsqtc
4672 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4673         sigtc=-sigtc/(fac*fac)
4674 C Following variable is sigma(t_c)**(-2)
4675         sigcsq=sigcsq*sigcsq
4676         sig0i=sig0(it)
4677         sig0inv=1.0D0/sig0i**2
4678         delthec=thetai-thet_pred_mean
4679         delthe0=thetai-theta0i
4680         term1=-0.5D0*sigcsq*delthec*delthec
4681         term2=-0.5D0*sig0inv*delthe0*delthe0
4682 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4683 C NaNs in taking the logarithm. We extract the largest exponent which is added
4684 C to the energy (this being the log of the distribution) at the end of energy
4685 C term evaluation for this virtual-bond angle.
4686         if (term1.gt.term2) then
4687           termm=term1
4688           term2=dexp(term2-termm)
4689           term1=1.0d0
4690         else
4691           termm=term2
4692           term1=dexp(term1-termm)
4693           term2=1.0d0
4694         endif
4695 C The ratio between the gamma-independent and gamma-dependent lobes of
4696 C the distribution is a Gaussian function of thet_pred_mean too.
4697         diffak=gthet(2,it)-thet_pred_mean
4698         ratak=diffak/gthet(3,it)**2
4699         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4700 C Let's differentiate it in thet_pred_mean NOW.
4701         aktc=ak*ratak
4702 C Now put together the distribution terms to make complete distribution.
4703         termexp=term1+ak*term2
4704         termpre=sigc+ak*sig0i
4705 C Contribution of the bending energy from this theta is just the -log of
4706 C the sum of the contributions from the two lobes and the pre-exponential
4707 C factor. Simple enough, isn't it?
4708         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4709 C NOW the derivatives!!!
4710 C 6/6/97 Take into account the deformation.
4711         E_theta=(delthec*sigcsq*term1
4712      &       +ak*delthe0*sig0inv*term2)/termexp
4713         E_tc=((sigtc+aktc*sig0i)/termpre
4714      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4715      &       aktc*term2)/termexp)
4716       return
4717       end
4718 c-----------------------------------------------------------------------------
4719       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4720       implicit real*8 (a-h,o-z)
4721       include 'DIMENSIONS'
4722       include 'COMMON.LOCAL'
4723       include 'COMMON.IOUNITS'
4724       common /calcthet/ term1,term2,termm,diffak,ratak,
4725      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4726      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4727       delthec=thetai-thet_pred_mean
4728       delthe0=thetai-theta0i
4729 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4730       t3 = thetai-thet_pred_mean
4731       t6 = t3**2
4732       t9 = term1
4733       t12 = t3*sigcsq
4734       t14 = t12+t6*sigsqtc
4735       t16 = 1.0d0
4736       t21 = thetai-theta0i
4737       t23 = t21**2
4738       t26 = term2
4739       t27 = t21*t26
4740       t32 = termexp
4741       t40 = t32**2
4742       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4743      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4744      & *(-t12*t9-ak*sig0inv*t27)
4745       return
4746       end
4747 #else
4748 C--------------------------------------------------------------------------
4749       subroutine ebend(etheta)
4750 C
4751 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4752 C angles gamma and its derivatives in consecutive thetas and gammas.
4753 C ab initio-derived potentials from
4754 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4755 C
4756       implicit real*8 (a-h,o-z)
4757       include 'DIMENSIONS'
4758       include 'COMMON.LOCAL'
4759       include 'COMMON.GEO'
4760       include 'COMMON.INTERACT'
4761       include 'COMMON.DERIV'
4762       include 'COMMON.VAR'
4763       include 'COMMON.CHAIN'
4764       include 'COMMON.IOUNITS'
4765       include 'COMMON.NAMES'
4766       include 'COMMON.FFIELD'
4767       include 'COMMON.CONTROL'
4768       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4769      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4770      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4771      & sinph1ph2(maxdouble,maxdouble)
4772       logical lprn /.false./, lprn1 /.false./
4773       etheta=0.0D0
4774       do i=ithet_start,ithet_end
4775         if (itype(i-1).eq.ntyp1) cycle
4776         if (iabs(itype(i+1)).eq.20) iblock=2
4777         if (iabs(itype(i+1)).ne.20) iblock=1
4778         dethetai=0.0d0
4779         dephii=0.0d0
4780         dephii1=0.0d0
4781         theti2=0.5d0*theta(i)
4782         ityp2=ithetyp((itype(i-1)))
4783         do k=1,nntheterm
4784           coskt(k)=dcos(k*theti2)
4785           sinkt(k)=dsin(k*theti2)
4786         enddo
4787         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4788 #ifdef OSF
4789           phii=phi(i)
4790           if (phii.ne.phii) phii=150.0
4791 #else
4792           phii=phi(i)
4793 #endif
4794           ityp1=ithetyp((itype(i-2)))
4795 C propagation of chirality for glycine type
4796           do k=1,nsingle
4797             cosph1(k)=dcos(k*phii)
4798             sinph1(k)=dsin(k*phii)
4799           enddo
4800         else
4801           phii=0.0d0
4802           ityp1=nthetyp+1
4803           do k=1,nsingle
4804             cosph1(k)=0.0d0
4805             sinph1(k)=0.0d0
4806           enddo
4807         endif
4808         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4809 #ifdef OSF
4810           phii1=phi(i+1)
4811           if (phii1.ne.phii1) phii1=150.0
4812           phii1=pinorm(phii1)
4813 #else
4814           phii1=phi(i+1)
4815 #endif
4816           ityp3=ithetyp((itype(i)))
4817           do k=1,nsingle
4818             cosph2(k)=dcos(k*phii1)
4819             sinph2(k)=dsin(k*phii1)
4820           enddo
4821         else
4822           phii1=0.0d0
4823           ityp3=nthetyp+1
4824           do k=1,nsingle
4825             cosph2(k)=0.0d0
4826             sinph2(k)=0.0d0
4827           enddo
4828         endif
4829         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4830         do k=1,ndouble
4831           do l=1,k-1
4832             ccl=cosph1(l)*cosph2(k-l)
4833             ssl=sinph1(l)*sinph2(k-l)
4834             scl=sinph1(l)*cosph2(k-l)
4835             csl=cosph1(l)*sinph2(k-l)
4836             cosph1ph2(l,k)=ccl-ssl
4837             cosph1ph2(k,l)=ccl+ssl
4838             sinph1ph2(l,k)=scl+csl
4839             sinph1ph2(k,l)=scl-csl
4840           enddo
4841         enddo
4842         if (lprn) then
4843         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4844      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4845         write (iout,*) "coskt and sinkt"
4846         do k=1,nntheterm
4847           write (iout,*) k,coskt(k),sinkt(k)
4848         enddo
4849         endif
4850         do k=1,ntheterm
4851           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4852           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4853      &      *coskt(k)
4854           if (lprn)
4855      &    write (iout,*) "k",k,"
4856      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4857      &     " ethetai",ethetai
4858         enddo
4859         if (lprn) then
4860         write (iout,*) "cosph and sinph"
4861         do k=1,nsingle
4862           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4863         enddo
4864         write (iout,*) "cosph1ph2 and sinph2ph2"
4865         do k=2,ndouble
4866           do l=1,k-1
4867             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4868      &         sinph1ph2(l,k),sinph1ph2(k,l)
4869           enddo
4870         enddo
4871         write(iout,*) "ethetai",ethetai
4872         endif
4873         do m=1,ntheterm2
4874           do k=1,nsingle
4875             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4876      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4877      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4878      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4879             ethetai=ethetai+sinkt(m)*aux
4880             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4881             dephii=dephii+k*sinkt(m)*(
4882      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4883      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4884             dephii1=dephii1+k*sinkt(m)*(
4885      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4886      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4887             if (lprn)
4888      &      write (iout,*) "m",m," k",k," bbthet",
4889      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4890      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4891      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4892      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4893           enddo
4894         enddo
4895         if (lprn)
4896      &  write(iout,*) "ethetai",ethetai
4897         do m=1,ntheterm3
4898           do k=2,ndouble
4899             do l=1,k-1
4900               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4901      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4902      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4903      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4904               ethetai=ethetai+sinkt(m)*aux
4905               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4906               dephii=dephii+l*sinkt(m)*(
4907      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4908      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4909      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4910      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4911               dephii1=dephii1+(k-l)*sinkt(m)*(
4912      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4913      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4914      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4915      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4916               if (lprn) then
4917               write (iout,*) "m",m," k",k," l",l," ffthet",
4918      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4919      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4920      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4921      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4922      &            " ethetai",ethetai
4923               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4924      &            cosph1ph2(k,l)*sinkt(m),
4925      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4926               endif
4927             enddo
4928           enddo
4929         enddo
4930 10      continue
4931 c        lprn1=.true.
4932         if (lprn1)
4933      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4934      &   i,theta(i)*rad2deg,phii*rad2deg,
4935      &   phii1*rad2deg,ethetai
4936 c        lprn1=.false.
4937         etheta=etheta+ethetai
4938         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4939         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4940         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
4941       enddo
4942       return
4943       end
4944 #endif
4945 #ifdef CRYST_SC
4946 c-----------------------------------------------------------------------------
4947       subroutine esc(escloc)
4948 C Calculate the local energy of a side chain and its derivatives in the
4949 C corresponding virtual-bond valence angles THETA and the spherical angles
4950 C ALPHA and OMEGA.
4951       implicit real*8 (a-h,o-z)
4952       include 'DIMENSIONS'
4953       include 'COMMON.GEO'
4954       include 'COMMON.LOCAL'
4955       include 'COMMON.VAR'
4956       include 'COMMON.INTERACT'
4957       include 'COMMON.DERIV'
4958       include 'COMMON.CHAIN'
4959       include 'COMMON.IOUNITS'
4960       include 'COMMON.NAMES'
4961       include 'COMMON.FFIELD'
4962       include 'COMMON.CONTROL'
4963       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4964      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4965       common /sccalc/ time11,time12,time112,theti,it,nlobit
4966       delta=0.02d0*pi
4967       escloc=0.0D0
4968 c     write (iout,'(a)') 'ESC'
4969       do i=loc_start,loc_end
4970         it=itype(i)
4971         if (it.eq.ntyp1) cycle
4972         if (it.eq.10) goto 1
4973         nlobit=nlob(iabs(it))
4974 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4975 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4976         theti=theta(i+1)-pipol
4977         x(1)=dtan(theti)
4978         x(2)=alph(i)
4979         x(3)=omeg(i)
4980
4981         if (x(2).gt.pi-delta) then
4982           xtemp(1)=x(1)
4983           xtemp(2)=pi-delta
4984           xtemp(3)=x(3)
4985           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4986           xtemp(2)=pi
4987           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4988           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4989      &        escloci,dersc(2))
4990           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4991      &        ddersc0(1),dersc(1))
4992           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4993      &        ddersc0(3),dersc(3))
4994           xtemp(2)=pi-delta
4995           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4996           xtemp(2)=pi
4997           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4998           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4999      &            dersc0(2),esclocbi,dersc02)
5000           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5001      &            dersc12,dersc01)
5002           call splinthet(x(2),0.5d0*delta,ss,ssd)
5003           dersc0(1)=dersc01
5004           dersc0(2)=dersc02
5005           dersc0(3)=0.0d0
5006           do k=1,3
5007             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5008           enddo
5009           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5010 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5011 c    &             esclocbi,ss,ssd
5012           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5013 c         escloci=esclocbi
5014 c         write (iout,*) escloci
5015         else if (x(2).lt.delta) then
5016           xtemp(1)=x(1)
5017           xtemp(2)=delta
5018           xtemp(3)=x(3)
5019           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5020           xtemp(2)=0.0d0
5021           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5022           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5023      &        escloci,dersc(2))
5024           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5025      &        ddersc0(1),dersc(1))
5026           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5027      &        ddersc0(3),dersc(3))
5028           xtemp(2)=delta
5029           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5030           xtemp(2)=0.0d0
5031           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5032           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5033      &            dersc0(2),esclocbi,dersc02)
5034           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5035      &            dersc12,dersc01)
5036           dersc0(1)=dersc01
5037           dersc0(2)=dersc02
5038           dersc0(3)=0.0d0
5039           call splinthet(x(2),0.5d0*delta,ss,ssd)
5040           do k=1,3
5041             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5042           enddo
5043           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5044 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5045 c    &             esclocbi,ss,ssd
5046           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5047 c         write (iout,*) escloci
5048         else
5049           call enesc(x,escloci,dersc,ddummy,.false.)
5050         endif
5051
5052         escloc=escloc+escloci
5053         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5054      &     'escloc',i,escloci
5055 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5056
5057         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5058      &   wscloc*dersc(1)
5059         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5060         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5061     1   continue
5062       enddo
5063       return
5064       end
5065 C---------------------------------------------------------------------------
5066       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5067       implicit real*8 (a-h,o-z)
5068       include 'DIMENSIONS'
5069       include 'COMMON.GEO'
5070       include 'COMMON.LOCAL'
5071       include 'COMMON.IOUNITS'
5072       common /sccalc/ time11,time12,time112,theti,it,nlobit
5073       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5074       double precision contr(maxlob,-1:1)
5075       logical mixed
5076 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5077         escloc_i=0.0D0
5078         do j=1,3
5079           dersc(j)=0.0D0
5080           if (mixed) ddersc(j)=0.0d0
5081         enddo
5082         x3=x(3)
5083
5084 C Because of periodicity of the dependence of the SC energy in omega we have
5085 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5086 C To avoid underflows, first compute & store the exponents.
5087
5088         do iii=-1,1
5089
5090           x(3)=x3+iii*dwapi
5091
5092           do j=1,nlobit
5093             do k=1,3
5094               z(k)=x(k)-censc(k,j,it)
5095             enddo
5096             do k=1,3
5097               Axk=0.0D0
5098               do l=1,3
5099                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5100               enddo
5101               Ax(k,j,iii)=Axk
5102             enddo
5103             expfac=0.0D0
5104             do k=1,3
5105               expfac=expfac+Ax(k,j,iii)*z(k)
5106             enddo
5107             contr(j,iii)=expfac
5108           enddo ! j
5109
5110         enddo ! iii
5111
5112         x(3)=x3
5113 C As in the case of ebend, we want to avoid underflows in exponentiation and
5114 C subsequent NaNs and INFs in energy calculation.
5115 C Find the largest exponent
5116         emin=contr(1,-1)
5117         do iii=-1,1
5118           do j=1,nlobit
5119             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5120           enddo
5121         enddo
5122         emin=0.5D0*emin
5123 cd      print *,'it=',it,' emin=',emin
5124
5125 C Compute the contribution to SC energy and derivatives
5126         do iii=-1,1
5127
5128           do j=1,nlobit
5129 #ifdef OSF
5130             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5131             if(adexp.ne.adexp) adexp=1.0
5132             expfac=dexp(adexp)
5133 #else
5134             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5135 #endif
5136 cd          print *,'j=',j,' expfac=',expfac
5137             escloc_i=escloc_i+expfac
5138             do k=1,3
5139               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5140             enddo
5141             if (mixed) then
5142               do k=1,3,2
5143                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5144      &            +gaussc(k,2,j,it))*expfac
5145               enddo
5146             endif
5147           enddo
5148
5149         enddo ! iii
5150
5151         dersc(1)=dersc(1)/cos(theti)**2
5152         ddersc(1)=ddersc(1)/cos(theti)**2
5153         ddersc(3)=ddersc(3)
5154
5155         escloci=-(dlog(escloc_i)-emin)
5156         do j=1,3
5157           dersc(j)=dersc(j)/escloc_i
5158         enddo
5159         if (mixed) then
5160           do j=1,3,2
5161             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5162           enddo
5163         endif
5164       return
5165       end
5166 C------------------------------------------------------------------------------
5167       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5168       implicit real*8 (a-h,o-z)
5169       include 'DIMENSIONS'
5170       include 'COMMON.GEO'
5171       include 'COMMON.LOCAL'
5172       include 'COMMON.IOUNITS'
5173       common /sccalc/ time11,time12,time112,theti,it,nlobit
5174       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5175       double precision contr(maxlob)
5176       logical mixed
5177
5178       escloc_i=0.0D0
5179
5180       do j=1,3
5181         dersc(j)=0.0D0
5182       enddo
5183
5184       do j=1,nlobit
5185         do k=1,2
5186           z(k)=x(k)-censc(k,j,it)
5187         enddo
5188         z(3)=dwapi
5189         do k=1,3
5190           Axk=0.0D0
5191           do l=1,3
5192             Axk=Axk+gaussc(l,k,j,it)*z(l)
5193           enddo
5194           Ax(k,j)=Axk
5195         enddo
5196         expfac=0.0D0
5197         do k=1,3
5198           expfac=expfac+Ax(k,j)*z(k)
5199         enddo
5200         contr(j)=expfac
5201       enddo ! j
5202
5203 C As in the case of ebend, we want to avoid underflows in exponentiation and
5204 C subsequent NaNs and INFs in energy calculation.
5205 C Find the largest exponent
5206       emin=contr(1)
5207       do j=1,nlobit
5208         if (emin.gt.contr(j)) emin=contr(j)
5209       enddo
5210       emin=0.5D0*emin
5211
5212 C Compute the contribution to SC energy and derivatives
5213
5214       dersc12=0.0d0
5215       do j=1,nlobit
5216         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5217         escloc_i=escloc_i+expfac
5218         do k=1,2
5219           dersc(k)=dersc(k)+Ax(k,j)*expfac
5220         enddo
5221         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5222      &            +gaussc(1,2,j,it))*expfac
5223         dersc(3)=0.0d0
5224       enddo
5225
5226       dersc(1)=dersc(1)/cos(theti)**2
5227       dersc12=dersc12/cos(theti)**2
5228       escloci=-(dlog(escloc_i)-emin)
5229       do j=1,2
5230         dersc(j)=dersc(j)/escloc_i
5231       enddo
5232       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5233       return
5234       end
5235 #else
5236 c----------------------------------------------------------------------------------
5237       subroutine esc(escloc)
5238 C Calculate the local energy of a side chain and its derivatives in the
5239 C corresponding virtual-bond valence angles THETA and the spherical angles
5240 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5241 C added by Urszula Kozlowska. 07/11/2007
5242 C
5243       implicit real*8 (a-h,o-z)
5244       include 'DIMENSIONS'
5245       include 'COMMON.GEO'
5246       include 'COMMON.LOCAL'
5247       include 'COMMON.VAR'
5248       include 'COMMON.SCROT'
5249       include 'COMMON.INTERACT'
5250       include 'COMMON.DERIV'
5251       include 'COMMON.CHAIN'
5252       include 'COMMON.IOUNITS'
5253       include 'COMMON.NAMES'
5254       include 'COMMON.FFIELD'
5255       include 'COMMON.CONTROL'
5256       include 'COMMON.VECTORS'
5257       double precision x_prime(3),y_prime(3),z_prime(3)
5258      &    , sumene,dsc_i,dp2_i,x(65),
5259      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5260      &    de_dxx,de_dyy,de_dzz,de_dt
5261       double precision s1_t,s1_6_t,s2_t,s2_6_t
5262       double precision
5263      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5264      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5265      & dt_dCi(3),dt_dCi1(3)
5266       common /sccalc/ time11,time12,time112,theti,it,nlobit
5267       delta=0.02d0*pi
5268       escloc=0.0D0
5269       do i=loc_start,loc_end
5270         if (itype(i).eq.ntyp1) cycle
5271         costtab(i+1) =dcos(theta(i+1))
5272         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5273         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5274         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5275         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5276         cosfac=dsqrt(cosfac2)
5277         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5278         sinfac=dsqrt(sinfac2)
5279         it=iabs(itype(i))
5280         if (it.eq.10) goto 1
5281 c
5282 C  Compute the axes of tghe local cartesian coordinates system; store in
5283 c   x_prime, y_prime and z_prime
5284 c
5285         do j=1,3
5286           x_prime(j) = 0.00
5287           y_prime(j) = 0.00
5288           z_prime(j) = 0.00
5289         enddo
5290 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5291 C     &   dc_norm(3,i+nres)
5292         do j = 1,3
5293           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5294           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5295         enddo
5296         do j = 1,3
5297           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5298         enddo
5299 c       write (2,*) "i",i
5300 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5301 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5302 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5303 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5304 c      & " xy",scalar(x_prime(1),y_prime(1)),
5305 c      & " xz",scalar(x_prime(1),z_prime(1)),
5306 c      & " yy",scalar(y_prime(1),y_prime(1)),
5307 c      & " yz",scalar(y_prime(1),z_prime(1)),
5308 c      & " zz",scalar(z_prime(1),z_prime(1))
5309 c
5310 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5311 C to local coordinate system. Store in xx, yy, zz.
5312 c
5313         xx=0.0d0
5314         yy=0.0d0
5315         zz=0.0d0
5316         do j = 1,3
5317           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5318           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5319           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5320         enddo
5321
5322         xxtab(i)=xx
5323         yytab(i)=yy
5324         zztab(i)=zz
5325 C
5326 C Compute the energy of the ith side cbain
5327 C
5328 c        write (2,*) "xx",xx," yy",yy," zz",zz
5329         it=iabs(itype(i))
5330         do j = 1,65
5331           x(j) = sc_parmin(j,it)
5332         enddo
5333 #ifdef CHECK_COORD
5334 Cc diagnostics - remove later
5335         xx1 = dcos(alph(2))
5336         yy1 = dsin(alph(2))*dcos(omeg(2))
5337         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5338         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5339      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5340      &    xx1,yy1,zz1
5341 C,"  --- ", xx_w,yy_w,zz_w
5342 c end diagnostics
5343 #endif
5344         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5345      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5346      &   + x(10)*yy*zz
5347         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5348      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5349      & + x(20)*yy*zz
5350         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5351      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5352      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5353      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5354      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5355      &  +x(40)*xx*yy*zz
5356         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5357      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5358      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5359      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5360      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5361      &  +x(60)*xx*yy*zz
5362         dsc_i   = 0.743d0+x(61)
5363         dp2_i   = 1.9d0+x(62)
5364         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5365      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5366         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5367      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5368         s1=(1+x(63))/(0.1d0 + dscp1)
5369         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5370         s2=(1+x(65))/(0.1d0 + dscp2)
5371         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5372         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5373      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5374 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5375 c     &   sumene4,
5376 c     &   dscp1,dscp2,sumene
5377 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5378         escloc = escloc + sumene
5379 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5380 c     & ,zz,xx,yy
5381 c#define DEBUG
5382 #ifdef DEBUG
5383 C
5384 C This section to check the numerical derivatives of the energy of ith side
5385 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5386 C #define DEBUG in the code to turn it on.
5387 C
5388         write (2,*) "sumene               =",sumene
5389         aincr=1.0d-7
5390         xxsave=xx
5391         xx=xx+aincr
5392         write (2,*) xx,yy,zz
5393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         de_dxx_num=(sumenep-sumene)/aincr
5395         xx=xxsave
5396         write (2,*) "xx+ sumene from enesc=",sumenep
5397         yysave=yy
5398         yy=yy+aincr
5399         write (2,*) xx,yy,zz
5400         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5401         de_dyy_num=(sumenep-sumene)/aincr
5402         yy=yysave
5403         write (2,*) "yy+ sumene from enesc=",sumenep
5404         zzsave=zz
5405         zz=zz+aincr
5406         write (2,*) xx,yy,zz
5407         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5408         de_dzz_num=(sumenep-sumene)/aincr
5409         zz=zzsave
5410         write (2,*) "zz+ sumene from enesc=",sumenep
5411         costsave=cost2tab(i+1)
5412         sintsave=sint2tab(i+1)
5413         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5414         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5415         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5416         de_dt_num=(sumenep-sumene)/aincr
5417         write (2,*) " t+ sumene from enesc=",sumenep
5418         cost2tab(i+1)=costsave
5419         sint2tab(i+1)=sintsave
5420 C End of diagnostics section.
5421 #endif
5422 C
5423 C Compute the gradient of esc
5424 C
5425 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5426         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5427         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5428         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5429         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5430         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5431         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5432         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5433         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5434         pom1=(sumene3*sint2tab(i+1)+sumene1)
5435      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5436         pom2=(sumene4*cost2tab(i+1)+sumene2)
5437      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5438         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5439         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5440      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5441      &  +x(40)*yy*zz
5442         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5443         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5444      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5445      &  +x(60)*yy*zz
5446         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5447      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5448      &        +(pom1+pom2)*pom_dx
5449 #ifdef DEBUG
5450         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5451 #endif
5452 C
5453         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5454         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5455      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5456      &  +x(40)*xx*zz
5457         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5458         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5459      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5460      &  +x(59)*zz**2 +x(60)*xx*zz
5461         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5462      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5463      &        +(pom1-pom2)*pom_dy
5464 #ifdef DEBUG
5465         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5466 #endif
5467 C
5468         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5469      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5470      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5471      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5472      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5473      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5474      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5475      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5476 #ifdef DEBUG
5477         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5478 #endif
5479 C
5480         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5481      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5482      &  +pom1*pom_dt1+pom2*pom_dt2
5483 #ifdef DEBUG
5484         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5485 #endif
5486 c#undef DEBUG
5487 c
5488 C
5489        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5490        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5491        cosfac2xx=cosfac2*xx
5492        sinfac2yy=sinfac2*yy
5493        do k = 1,3
5494          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5495      &      vbld_inv(i+1)
5496          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5497      &      vbld_inv(i)
5498          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5499          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5500 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5501 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5502 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5503 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5504          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5505          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5506          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5507          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5508          dZZ_Ci1(k)=0.0d0
5509          dZZ_Ci(k)=0.0d0
5510          do j=1,3
5511            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5512      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5513            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5514      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5515          enddo
5516
5517          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5518          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5519          dZZ_XYZ(k)=vbld_inv(i+nres)*
5520      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5521 c
5522          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5523          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5524        enddo
5525
5526        do k=1,3
5527          dXX_Ctab(k,i)=dXX_Ci(k)
5528          dXX_C1tab(k,i)=dXX_Ci1(k)
5529          dYY_Ctab(k,i)=dYY_Ci(k)
5530          dYY_C1tab(k,i)=dYY_Ci1(k)
5531          dZZ_Ctab(k,i)=dZZ_Ci(k)
5532          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5533          dXX_XYZtab(k,i)=dXX_XYZ(k)
5534          dYY_XYZtab(k,i)=dYY_XYZ(k)
5535          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5536        enddo
5537
5538        do k = 1,3
5539 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5540 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5541 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5542 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5543 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5544 c     &    dt_dci(k)
5545 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5546 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5547          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5548      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5549          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5550      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5551          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5552      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5553        enddo
5554 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5555 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5556
5557 C to check gradient call subroutine check_grad
5558
5559     1 continue
5560       enddo
5561       return
5562       end
5563 c------------------------------------------------------------------------------
5564       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5565       implicit none
5566       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5567      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5568       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5569      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5570      &   + x(10)*yy*zz
5571       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5572      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5573      & + x(20)*yy*zz
5574       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5575      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5576      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5577      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5578      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5579      &  +x(40)*xx*yy*zz
5580       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5581      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5582      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5583      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5584      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5585      &  +x(60)*xx*yy*zz
5586       dsc_i   = 0.743d0+x(61)
5587       dp2_i   = 1.9d0+x(62)
5588       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5589      &          *(xx*cost2+yy*sint2))
5590       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5591      &          *(xx*cost2-yy*sint2))
5592       s1=(1+x(63))/(0.1d0 + dscp1)
5593       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5594       s2=(1+x(65))/(0.1d0 + dscp2)
5595       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5596       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5597      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5598       enesc=sumene
5599       return
5600       end
5601 #endif
5602 c------------------------------------------------------------------------------
5603       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5604 C
5605 C This procedure calculates two-body contact function g(rij) and its derivative:
5606 C
5607 C           eps0ij                                     !       x < -1
5608 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5609 C            0                                         !       x > 1
5610 C
5611 C where x=(rij-r0ij)/delta
5612 C
5613 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5614 C
5615       implicit none
5616       double precision rij,r0ij,eps0ij,fcont,fprimcont
5617       double precision x,x2,x4,delta
5618 c     delta=0.02D0*r0ij
5619 c      delta=0.2D0*r0ij
5620       x=(rij-r0ij)/delta
5621       if (x.lt.-1.0D0) then
5622         fcont=eps0ij
5623         fprimcont=0.0D0
5624       else if (x.le.1.0D0) then
5625         x2=x*x
5626         x4=x2*x2
5627         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5628         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5629       else
5630         fcont=0.0D0
5631         fprimcont=0.0D0
5632       endif
5633       return
5634       end
5635 c------------------------------------------------------------------------------
5636       subroutine splinthet(theti,delta,ss,ssder)
5637       implicit real*8 (a-h,o-z)
5638       include 'DIMENSIONS'
5639       include 'COMMON.VAR'
5640       include 'COMMON.GEO'
5641       thetup=pi-delta
5642       thetlow=delta
5643       if (theti.gt.pipol) then
5644         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5645       else
5646         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5647         ssder=-ssder
5648       endif
5649       return
5650       end
5651 c------------------------------------------------------------------------------
5652       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5653       implicit none
5654       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5655       double precision ksi,ksi2,ksi3,a1,a2,a3
5656       a1=fprim0*delta/(f1-f0)
5657       a2=3.0d0-2.0d0*a1
5658       a3=a1-2.0d0
5659       ksi=(x-x0)/delta
5660       ksi2=ksi*ksi
5661       ksi3=ksi2*ksi
5662       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5663       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5664       return
5665       end
5666 c------------------------------------------------------------------------------
5667       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5668       implicit none
5669       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5670       double precision ksi,ksi2,ksi3,a1,a2,a3
5671       ksi=(x-x0)/delta
5672       ksi2=ksi*ksi
5673       ksi3=ksi2*ksi
5674       a1=fprim0x*delta
5675       a2=3*(f1x-f0x)-2*fprim0x*delta
5676       a3=fprim0x*delta-2*(f1x-f0x)
5677       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5678       return
5679       end
5680 C-----------------------------------------------------------------------------
5681 #ifdef CRYST_TOR
5682 C-----------------------------------------------------------------------------
5683       subroutine etor(etors,edihcnstr)
5684       implicit real*8 (a-h,o-z)
5685       include 'DIMENSIONS'
5686       include 'COMMON.VAR'
5687       include 'COMMON.GEO'
5688       include 'COMMON.LOCAL'
5689       include 'COMMON.TORSION'
5690       include 'COMMON.INTERACT'
5691       include 'COMMON.DERIV'
5692       include 'COMMON.CHAIN'
5693       include 'COMMON.NAMES'
5694       include 'COMMON.IOUNITS'
5695       include 'COMMON.FFIELD'
5696       include 'COMMON.TORCNSTR'
5697       include 'COMMON.CONTROL'
5698       logical lprn
5699 C Set lprn=.true. for debugging
5700       lprn=.false.
5701 c      lprn=.true.
5702       etors=0.0D0
5703       do i=iphi_start,iphi_end
5704       etors_ii=0.0D0
5705         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5706      &      .or. itype(i).eq.ntyp1) cycle
5707         itori=itortyp(itype(i-2))
5708         itori1=itortyp(itype(i-1))
5709         phii=phi(i)
5710         gloci=0.0D0
5711 C Proline-Proline pair is a special case...
5712         if (itori.eq.3 .and. itori1.eq.3) then
5713           if (phii.gt.-dwapi3) then
5714             cosphi=dcos(3*phii)
5715             fac=1.0D0/(1.0D0-cosphi)
5716             etorsi=v1(1,3,3)*fac
5717             etorsi=etorsi+etorsi
5718             etors=etors+etorsi-v1(1,3,3)
5719             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5720             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5721           endif
5722           do j=1,3
5723             v1ij=v1(j+1,itori,itori1)
5724             v2ij=v2(j+1,itori,itori1)
5725             cosphi=dcos(j*phii)
5726             sinphi=dsin(j*phii)
5727             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5728             if (energy_dec) etors_ii=etors_ii+
5729      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5730             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5731           enddo
5732         else
5733           do j=1,nterm_old
5734             v1ij=v1(j,itori,itori1)
5735             v2ij=v2(j,itori,itori1)
5736             cosphi=dcos(j*phii)
5737             sinphi=dsin(j*phii)
5738             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5739             if (energy_dec) etors_ii=etors_ii+
5740      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5741             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5742           enddo
5743         endif
5744         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5745              'etor',i,etors_ii
5746         if (lprn)
5747      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5748      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5749      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5750         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5751 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5752       enddo
5753 ! 6/20/98 - dihedral angle constraints
5754       edihcnstr=0.0d0
5755       do i=1,ndih_constr
5756         itori=idih_constr(i)
5757         phii=phi(itori)
5758         difi=phii-phi0(i)
5759         if (difi.gt.drange(i)) then
5760           difi=difi-drange(i)
5761           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5762           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5763         else if (difi.lt.-drange(i)) then
5764           difi=difi+drange(i)
5765           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5766           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5767         endif
5768 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5769 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5770       enddo
5771 !      write (iout,*) 'edihcnstr',edihcnstr
5772       return
5773       end
5774 c------------------------------------------------------------------------------
5775       subroutine etor_d(etors_d)
5776       etors_d=0.0d0
5777       return
5778       end
5779 c----------------------------------------------------------------------------
5780 #else
5781       subroutine etor(etors,edihcnstr)
5782       implicit real*8 (a-h,o-z)
5783       include 'DIMENSIONS'
5784       include 'COMMON.VAR'
5785       include 'COMMON.GEO'
5786       include 'COMMON.LOCAL'
5787       include 'COMMON.TORSION'
5788       include 'COMMON.INTERACT'
5789       include 'COMMON.DERIV'
5790       include 'COMMON.CHAIN'
5791       include 'COMMON.NAMES'
5792       include 'COMMON.IOUNITS'
5793       include 'COMMON.FFIELD'
5794       include 'COMMON.TORCNSTR'
5795       include 'COMMON.CONTROL'
5796       logical lprn
5797 C Set lprn=.true. for debugging
5798       lprn=.false.
5799 c     lprn=.true.
5800       etors=0.0D0
5801       do i=iphi_start,iphi_end
5802         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5803      &       .or. itype(i).eq.ntyp1) cycle
5804         etors_ii=0.0D0
5805          if (iabs(itype(i)).eq.20) then
5806          iblock=2
5807          else
5808          iblock=1
5809          endif
5810         itori=itortyp(itype(i-2))
5811         itori1=itortyp(itype(i-1))
5812         phii=phi(i)
5813         gloci=0.0D0
5814 C Regular cosine and sine terms
5815         do j=1,nterm(itori,itori1,iblock)
5816           v1ij=v1(j,itori,itori1,iblock)
5817           v2ij=v2(j,itori,itori1,iblock)
5818           cosphi=dcos(j*phii)
5819           sinphi=dsin(j*phii)
5820           etors=etors+v1ij*cosphi+v2ij*sinphi
5821           if (energy_dec) etors_ii=etors_ii+
5822      &                v1ij*cosphi+v2ij*sinphi
5823           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5824         enddo
5825 C Lorentz terms
5826 C                         v1
5827 C  E = SUM ----------------------------------- - v1
5828 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5829 C
5830         cosphi=dcos(0.5d0*phii)
5831         sinphi=dsin(0.5d0*phii)
5832         do j=1,nlor(itori,itori1,iblock)
5833           vl1ij=vlor1(j,itori,itori1)
5834           vl2ij=vlor2(j,itori,itori1)
5835           vl3ij=vlor3(j,itori,itori1)
5836           pom=vl2ij*cosphi+vl3ij*sinphi
5837           pom1=1.0d0/(pom*pom+1.0d0)
5838           etors=etors+vl1ij*pom1
5839           if (energy_dec) etors_ii=etors_ii+
5840      &                vl1ij*pom1
5841           pom=-pom*pom1*pom1
5842           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5843         enddo
5844 C Subtract the constant term
5845         etors=etors-v0(itori,itori1,iblock)
5846           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5847      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5848         if (lprn)
5849      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5850      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5851      &  (v1(j,itori,itori1,iblock),j=1,6),
5852      &  (v2(j,itori,itori1,iblock),j=1,6)
5853         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5854 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5855       enddo
5856 ! 6/20/98 - dihedral angle constraints
5857       edihcnstr=0.0d0
5858 c      do i=1,ndih_constr
5859       do i=idihconstr_start,idihconstr_end
5860         itori=idih_constr(i)
5861         phii=phi(itori)
5862         difi=pinorm(phii-phi0(i))
5863         if (difi.gt.drange(i)) then
5864           difi=difi-drange(i)
5865           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5866           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5867         else if (difi.lt.-drange(i)) then
5868           difi=difi+drange(i)
5869           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5870           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5871         else
5872           difi=0.0
5873         endif
5874 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5875 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5876 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5877       enddo
5878 cd       write (iout,*) 'edihcnstr',edihcnstr
5879       return
5880       end
5881 c----------------------------------------------------------------------------
5882       subroutine etor_d(etors_d)
5883 C 6/23/01 Compute double torsional energy
5884       implicit real*8 (a-h,o-z)
5885       include 'DIMENSIONS'
5886       include 'COMMON.VAR'
5887       include 'COMMON.GEO'
5888       include 'COMMON.LOCAL'
5889       include 'COMMON.TORSION'
5890       include 'COMMON.INTERACT'
5891       include 'COMMON.DERIV'
5892       include 'COMMON.CHAIN'
5893       include 'COMMON.NAMES'
5894       include 'COMMON.IOUNITS'
5895       include 'COMMON.FFIELD'
5896       include 'COMMON.TORCNSTR'
5897       logical lprn
5898 C Set lprn=.true. for debugging
5899       lprn=.false.
5900 c     lprn=.true.
5901       etors_d=0.0D0
5902 c      write(iout,*) "a tu??"
5903       do i=iphid_start,iphid_end
5904         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5905      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5906         itori=itortyp(itype(i-2))
5907         itori1=itortyp(itype(i-1))
5908         itori2=itortyp(itype(i))
5909         phii=phi(i)
5910         phii1=phi(i+1)
5911         gloci1=0.0D0
5912         gloci2=0.0D0
5913         iblock=1
5914         if (iabs(itype(i+1)).eq.20) iblock=2
5915
5916 C Regular cosine and sine terms
5917         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5918           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5919           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5920           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5921           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5922           cosphi1=dcos(j*phii)
5923           sinphi1=dsin(j*phii)
5924           cosphi2=dcos(j*phii1)
5925           sinphi2=dsin(j*phii1)
5926           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5927      &     v2cij*cosphi2+v2sij*sinphi2
5928           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5929           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5930         enddo
5931         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5932           do l=1,k-1
5933             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5934             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5935             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5936             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5937             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5938             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5939             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5940             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5941             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5942      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5943             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5944      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5945             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5946      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5947           enddo
5948         enddo
5949         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5950         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5951       enddo
5952       return
5953       end
5954 #endif
5955 c------------------------------------------------------------------------------
5956       subroutine eback_sc_corr(esccor)
5957 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5958 c        conformational states; temporarily implemented as differences
5959 c        between UNRES torsional potentials (dependent on three types of
5960 c        residues) and the torsional potentials dependent on all 20 types
5961 c        of residues computed from AM1  energy surfaces of terminally-blocked
5962 c        amino-acid residues.
5963       implicit real*8 (a-h,o-z)
5964       include 'DIMENSIONS'
5965       include 'COMMON.VAR'
5966       include 'COMMON.GEO'
5967       include 'COMMON.LOCAL'
5968       include 'COMMON.TORSION'
5969       include 'COMMON.SCCOR'
5970       include 'COMMON.INTERACT'
5971       include 'COMMON.DERIV'
5972       include 'COMMON.CHAIN'
5973       include 'COMMON.NAMES'
5974       include 'COMMON.IOUNITS'
5975       include 'COMMON.FFIELD'
5976       include 'COMMON.CONTROL'
5977       logical lprn
5978 C Set lprn=.true. for debugging
5979       lprn=.false.
5980 c      lprn=.true.
5981 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5982       esccor=0.0D0
5983       do i=itau_start,itau_end
5984         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5985         esccor_ii=0.0D0
5986         isccori=isccortyp(itype(i-2))
5987         isccori1=isccortyp(itype(i-1))
5988 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5989         phii=phi(i)
5990         do intertyp=1,3 !intertyp
5991 cc Added 09 May 2012 (Adasko)
5992 cc  Intertyp means interaction type of backbone mainchain correlation:
5993 c   1 = SC...Ca...Ca...Ca
5994 c   2 = Ca...Ca...Ca...SC
5995 c   3 = SC...Ca...Ca...SCi
5996         gloci=0.0D0
5997         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5998      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5999      &      (itype(i-1).eq.ntyp1)))
6000      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6001      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6002      &     .or.(itype(i).eq.ntyp1)))
6003      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6004      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6005      &      (itype(i-3).eq.ntyp1)))) cycle
6006         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6007         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6008      & cycle
6009        do j=1,nterm_sccor(isccori,isccori1)
6010           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6011           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6012           cosphi=dcos(j*tauangle(intertyp,i))
6013           sinphi=dsin(j*tauangle(intertyp,i))
6014           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6015           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6016         enddo
6017 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6018         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6019         if (lprn)
6020      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6021      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6022      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6023      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6024         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6025        enddo !intertyp
6026       enddo
6027
6028       return
6029       end
6030 c----------------------------------------------------------------------------
6031       subroutine multibody(ecorr)
6032 C This subroutine calculates multi-body contributions to energy following
6033 C the idea of Skolnick et al. If side chains I and J make a contact and
6034 C at the same time side chains I+1 and J+1 make a contact, an extra
6035 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6036       implicit real*8 (a-h,o-z)
6037       include 'DIMENSIONS'
6038       include 'COMMON.IOUNITS'
6039       include 'COMMON.DERIV'
6040       include 'COMMON.INTERACT'
6041       include 'COMMON.CONTACTS'
6042       double precision gx(3),gx1(3)
6043       logical lprn
6044
6045 C Set lprn=.true. for debugging
6046       lprn=.false.
6047
6048       if (lprn) then
6049         write (iout,'(a)') 'Contact function values:'
6050         do i=nnt,nct-2
6051           write (iout,'(i2,20(1x,i2,f10.5))')
6052      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6053         enddo
6054       endif
6055       ecorr=0.0D0
6056       do i=nnt,nct
6057         do j=1,3
6058           gradcorr(j,i)=0.0D0
6059           gradxorr(j,i)=0.0D0
6060         enddo
6061       enddo
6062       do i=nnt,nct-2
6063
6064         DO ISHIFT = 3,4
6065
6066         i1=i+ishift
6067         num_conti=num_cont(i)
6068         num_conti1=num_cont(i1)
6069         do jj=1,num_conti
6070           j=jcont(jj,i)
6071           do kk=1,num_conti1
6072             j1=jcont(kk,i1)
6073             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6074 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6075 cd   &                   ' ishift=',ishift
6076 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6077 C The system gains extra energy.
6078               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6079             endif   ! j1==j+-ishift
6080           enddo     ! kk
6081         enddo       ! jj
6082
6083         ENDDO ! ISHIFT
6084
6085       enddo         ! i
6086       return
6087       end
6088 c------------------------------------------------------------------------------
6089       double precision function esccorr(i,j,k,l,jj,kk)
6090       implicit real*8 (a-h,o-z)
6091       include 'DIMENSIONS'
6092       include 'COMMON.IOUNITS'
6093       include 'COMMON.DERIV'
6094       include 'COMMON.INTERACT'
6095       include 'COMMON.CONTACTS'
6096       double precision gx(3),gx1(3)
6097       logical lprn
6098       lprn=.false.
6099       eij=facont(jj,i)
6100       ekl=facont(kk,k)
6101 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6102 C Calculate the multi-body contribution to energy.
6103 C Calculate multi-body contributions to the gradient.
6104 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6105 cd   & k,l,(gacont(m,kk,k),m=1,3)
6106       do m=1,3
6107         gx(m) =ekl*gacont(m,jj,i)
6108         gx1(m)=eij*gacont(m,kk,k)
6109         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6110         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6111         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6112         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6113       enddo
6114       do m=i,j-1
6115         do ll=1,3
6116           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6117         enddo
6118       enddo
6119       do m=k,l-1
6120         do ll=1,3
6121           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6122         enddo
6123       enddo
6124       esccorr=-eij*ekl
6125       return
6126       end
6127 c------------------------------------------------------------------------------
6128       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6129 C This subroutine calculates multi-body contributions to hydrogen-bonding
6130       implicit real*8 (a-h,o-z)
6131       include 'DIMENSIONS'
6132       include 'COMMON.IOUNITS'
6133 #ifdef MPI
6134       include "mpif.h"
6135       parameter (max_cont=maxconts)
6136       parameter (max_dim=26)
6137       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6138       double precision zapas(max_dim,maxconts,max_fg_procs),
6139      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6140       common /przechowalnia/ zapas
6141       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6142      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6143 #endif
6144       include 'COMMON.SETUP'
6145       include 'COMMON.FFIELD'
6146       include 'COMMON.DERIV'
6147       include 'COMMON.INTERACT'
6148       include 'COMMON.CONTACTS'
6149       include 'COMMON.CONTROL'
6150       include 'COMMON.LOCAL'
6151       double precision gx(3),gx1(3),time00
6152       logical lprn,ldone
6153
6154 C Set lprn=.true. for debugging
6155       lprn=.false.
6156 #ifdef MPI
6157       n_corr=0
6158       n_corr1=0
6159       if (nfgtasks.le.1) goto 30
6160       if (lprn) then
6161         write (iout,'(a)') 'Contact function values before RECEIVE:'
6162         do i=nnt,nct-2
6163           write (iout,'(2i3,50(1x,i2,f5.2))')
6164      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6165      &    j=1,num_cont_hb(i))
6166         enddo
6167       endif
6168       call flush(iout)
6169       do i=1,ntask_cont_from
6170         ncont_recv(i)=0
6171       enddo
6172       do i=1,ntask_cont_to
6173         ncont_sent(i)=0
6174       enddo
6175 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6176 c     & ntask_cont_to
6177 C Make the list of contacts to send to send to other procesors
6178 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6179 c      call flush(iout)
6180       do i=iturn3_start,iturn3_end
6181 c        write (iout,*) "make contact list turn3",i," num_cont",
6182 c     &    num_cont_hb(i)
6183         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6184       enddo
6185       do i=iturn4_start,iturn4_end
6186 c        write (iout,*) "make contact list turn4",i," num_cont",
6187 c     &   num_cont_hb(i)
6188         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6189       enddo
6190       do ii=1,nat_sent
6191         i=iat_sent(ii)
6192 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6193 c     &    num_cont_hb(i)
6194         do j=1,num_cont_hb(i)
6195         do k=1,4
6196           jjc=jcont_hb(j,i)
6197           iproc=iint_sent_local(k,jjc,ii)
6198 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6199           if (iproc.gt.0) then
6200             ncont_sent(iproc)=ncont_sent(iproc)+1
6201             nn=ncont_sent(iproc)
6202             zapas(1,nn,iproc)=i
6203             zapas(2,nn,iproc)=jjc
6204             zapas(3,nn,iproc)=facont_hb(j,i)
6205             zapas(4,nn,iproc)=ees0p(j,i)
6206             zapas(5,nn,iproc)=ees0m(j,i)
6207             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6208             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6209             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6210             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6211             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6212             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6213             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6214             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6215             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6216             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6217             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6218             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6219             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6220             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6221             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6222             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6223             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6224             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6225             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6226             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6227             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6228           endif
6229         enddo
6230         enddo
6231       enddo
6232       if (lprn) then
6233       write (iout,*)
6234      &  "Numbers of contacts to be sent to other processors",
6235      &  (ncont_sent(i),i=1,ntask_cont_to)
6236       write (iout,*) "Contacts sent"
6237       do ii=1,ntask_cont_to
6238         nn=ncont_sent(ii)
6239         iproc=itask_cont_to(ii)
6240         write (iout,*) nn," contacts to processor",iproc,
6241      &   " of CONT_TO_COMM group"
6242         do i=1,nn
6243           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6244         enddo
6245       enddo
6246       call flush(iout)
6247       endif
6248       CorrelType=477
6249       CorrelID=fg_rank+1
6250       CorrelType1=478
6251       CorrelID1=nfgtasks+fg_rank+1
6252       ireq=0
6253 C Receive the numbers of needed contacts from other processors
6254       do ii=1,ntask_cont_from
6255         iproc=itask_cont_from(ii)
6256         ireq=ireq+1
6257         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6258      &    FG_COMM,req(ireq),IERR)
6259       enddo
6260 c      write (iout,*) "IRECV ended"
6261 c      call flush(iout)
6262 C Send the number of contacts needed by other processors
6263       do ii=1,ntask_cont_to
6264         iproc=itask_cont_to(ii)
6265         ireq=ireq+1
6266         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6267      &    FG_COMM,req(ireq),IERR)
6268       enddo
6269 c      write (iout,*) "ISEND ended"
6270 c      write (iout,*) "number of requests (nn)",ireq
6271       call flush(iout)
6272       if (ireq.gt.0)
6273      &  call MPI_Waitall(ireq,req,status_array,ierr)
6274 c      write (iout,*)
6275 c     &  "Numbers of contacts to be received from other processors",
6276 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6277 c      call flush(iout)
6278 C Receive contacts
6279       ireq=0
6280       do ii=1,ntask_cont_from
6281         iproc=itask_cont_from(ii)
6282         nn=ncont_recv(ii)
6283 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6284 c     &   " of CONT_TO_COMM group"
6285         call flush(iout)
6286         if (nn.gt.0) then
6287           ireq=ireq+1
6288           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6289      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6290 c          write (iout,*) "ireq,req",ireq,req(ireq)
6291         endif
6292       enddo
6293 C Send the contacts to processors that need them
6294       do ii=1,ntask_cont_to
6295         iproc=itask_cont_to(ii)
6296         nn=ncont_sent(ii)
6297 c        write (iout,*) nn," contacts to processor",iproc,
6298 c     &   " of CONT_TO_COMM group"
6299         if (nn.gt.0) then
6300           ireq=ireq+1
6301           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6302      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6303 c          write (iout,*) "ireq,req",ireq,req(ireq)
6304 c          do i=1,nn
6305 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6306 c          enddo
6307         endif
6308       enddo
6309 c      write (iout,*) "number of requests (contacts)",ireq
6310 c      write (iout,*) "req",(req(i),i=1,4)
6311 c      call flush(iout)
6312       if (ireq.gt.0)
6313      & call MPI_Waitall(ireq,req,status_array,ierr)
6314       do iii=1,ntask_cont_from
6315         iproc=itask_cont_from(iii)
6316         nn=ncont_recv(iii)
6317         if (lprn) then
6318         write (iout,*) "Received",nn," contacts from processor",iproc,
6319      &   " of CONT_FROM_COMM group"
6320         call flush(iout)
6321         do i=1,nn
6322           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6323         enddo
6324         call flush(iout)
6325         endif
6326         do i=1,nn
6327           ii=zapas_recv(1,i,iii)
6328 c Flag the received contacts to prevent double-counting
6329           jj=-zapas_recv(2,i,iii)
6330 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6331 c          call flush(iout)
6332           nnn=num_cont_hb(ii)+1
6333           num_cont_hb(ii)=nnn
6334           jcont_hb(nnn,ii)=jj
6335           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6336           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6337           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6338           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6339           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6340           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6341           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6342           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6343           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6344           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6345           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6346           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6347           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6348           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6349           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6350           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6351           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6352           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6353           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6354           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6355           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6356           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6357           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6358           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6359         enddo
6360       enddo
6361       call flush(iout)
6362       if (lprn) then
6363         write (iout,'(a)') 'Contact function values after receive:'
6364         do i=nnt,nct-2
6365           write (iout,'(2i3,50(1x,i3,f5.2))')
6366      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6367      &    j=1,num_cont_hb(i))
6368         enddo
6369         call flush(iout)
6370       endif
6371    30 continue
6372 #endif
6373       if (lprn) then
6374         write (iout,'(a)') 'Contact function values:'
6375         do i=nnt,nct-2
6376           write (iout,'(2i3,50(1x,i3,f5.2))')
6377      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6378      &    j=1,num_cont_hb(i))
6379         enddo
6380       endif
6381       ecorr=0.0D0
6382 C Remove the loop below after debugging !!!
6383       do i=nnt,nct
6384         do j=1,3
6385           gradcorr(j,i)=0.0D0
6386           gradxorr(j,i)=0.0D0
6387         enddo
6388       enddo
6389 C Calculate the local-electrostatic correlation terms
6390       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6391         i1=i+1
6392         num_conti=num_cont_hb(i)
6393         num_conti1=num_cont_hb(i+1)
6394         do jj=1,num_conti
6395           j=jcont_hb(jj,i)
6396           jp=iabs(j)
6397           do kk=1,num_conti1
6398             j1=jcont_hb(kk,i1)
6399             jp1=iabs(j1)
6400 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6401 c     &         ' jj=',jj,' kk=',kk
6402             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6403      &          .or. j.lt.0 .and. j1.gt.0) .and.
6404      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6405 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6406 C The system gains extra energy.
6407               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6408               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6409      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6410               n_corr=n_corr+1
6411             else if (j1.eq.j) then
6412 C Contacts I-J and I-(J+1) occur simultaneously.
6413 C The system loses extra energy.
6414 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6415             endif
6416           enddo ! kk
6417           do kk=1,num_conti
6418             j1=jcont_hb(kk,i)
6419 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6420 c    &         ' jj=',jj,' kk=',kk
6421             if (j1.eq.j+1) then
6422 C Contacts I-J and (I+1)-J occur simultaneously.
6423 C The system loses extra energy.
6424 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6425             endif ! j1==j+1
6426           enddo ! kk
6427         enddo ! jj
6428       enddo ! i
6429       return
6430       end
6431 c------------------------------------------------------------------------------
6432       subroutine add_hb_contact(ii,jj,itask)
6433       implicit real*8 (a-h,o-z)
6434       include "DIMENSIONS"
6435       include "COMMON.IOUNITS"
6436       integer max_cont
6437       integer max_dim
6438       parameter (max_cont=maxconts)
6439       parameter (max_dim=26)
6440       include "COMMON.CONTACTS"
6441       double precision zapas(max_dim,maxconts,max_fg_procs),
6442      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6443       common /przechowalnia/ zapas
6444       integer i,j,ii,jj,iproc,itask(4),nn
6445 c      write (iout,*) "itask",itask
6446       do i=1,2
6447         iproc=itask(i)
6448         if (iproc.gt.0) then
6449           do j=1,num_cont_hb(ii)
6450             jjc=jcont_hb(j,ii)
6451 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6452             if (jjc.eq.jj) then
6453               ncont_sent(iproc)=ncont_sent(iproc)+1
6454               nn=ncont_sent(iproc)
6455               zapas(1,nn,iproc)=ii
6456               zapas(2,nn,iproc)=jjc
6457               zapas(3,nn,iproc)=facont_hb(j,ii)
6458               zapas(4,nn,iproc)=ees0p(j,ii)
6459               zapas(5,nn,iproc)=ees0m(j,ii)
6460               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6461               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6462               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6463               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6464               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6465               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6466               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6467               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6468               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6469               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6470               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6471               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6472               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6473               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6474               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6475               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6476               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6477               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6478               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6479               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6480               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6481               exit
6482             endif
6483           enddo
6484         endif
6485       enddo
6486       return
6487       end
6488 c------------------------------------------------------------------------------
6489       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6490      &  n_corr1)
6491 C This subroutine calculates multi-body contributions to hydrogen-bonding
6492       implicit real*8 (a-h,o-z)
6493       include 'DIMENSIONS'
6494       include 'COMMON.IOUNITS'
6495 #ifdef MPI
6496       include "mpif.h"
6497       parameter (max_cont=maxconts)
6498       parameter (max_dim=70)
6499       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6500       double precision zapas(max_dim,maxconts,max_fg_procs),
6501      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6502       common /przechowalnia/ zapas
6503       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6504      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6505 #endif
6506       include 'COMMON.SETUP'
6507       include 'COMMON.FFIELD'
6508       include 'COMMON.DERIV'
6509       include 'COMMON.LOCAL'
6510       include 'COMMON.INTERACT'
6511       include 'COMMON.CONTACTS'
6512       include 'COMMON.CHAIN'
6513       include 'COMMON.CONTROL'
6514       double precision gx(3),gx1(3)
6515       integer num_cont_hb_old(maxres)
6516       logical lprn,ldone
6517       double precision eello4,eello5,eelo6,eello_turn6
6518       external eello4,eello5,eello6,eello_turn6
6519 C Set lprn=.true. for debugging
6520       lprn=.false.
6521       eturn6=0.0d0
6522 #ifdef MPI
6523       do i=1,nres
6524         num_cont_hb_old(i)=num_cont_hb(i)
6525       enddo
6526       n_corr=0
6527       n_corr1=0
6528       if (nfgtasks.le.1) goto 30
6529       if (lprn) then
6530         write (iout,'(a)') 'Contact function values before RECEIVE:'
6531         do i=nnt,nct-2
6532           write (iout,'(2i3,50(1x,i2,f5.2))')
6533      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6534      &    j=1,num_cont_hb(i))
6535         enddo
6536       endif
6537       call flush(iout)
6538       do i=1,ntask_cont_from
6539         ncont_recv(i)=0
6540       enddo
6541       do i=1,ntask_cont_to
6542         ncont_sent(i)=0
6543       enddo
6544 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6545 c     & ntask_cont_to
6546 C Make the list of contacts to send to send to other procesors
6547       do i=iturn3_start,iturn3_end
6548 c        write (iout,*) "make contact list turn3",i," num_cont",
6549 c     &    num_cont_hb(i)
6550         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6551       enddo
6552       do i=iturn4_start,iturn4_end
6553 c        write (iout,*) "make contact list turn4",i," num_cont",
6554 c     &   num_cont_hb(i)
6555         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6556       enddo
6557       do ii=1,nat_sent
6558         i=iat_sent(ii)
6559 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6560 c     &    num_cont_hb(i)
6561         do j=1,num_cont_hb(i)
6562         do k=1,4
6563           jjc=jcont_hb(j,i)
6564           iproc=iint_sent_local(k,jjc,ii)
6565 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6566           if (iproc.ne.0) then
6567             ncont_sent(iproc)=ncont_sent(iproc)+1
6568             nn=ncont_sent(iproc)
6569             zapas(1,nn,iproc)=i
6570             zapas(2,nn,iproc)=jjc
6571             zapas(3,nn,iproc)=d_cont(j,i)
6572             ind=3
6573             do kk=1,3
6574               ind=ind+1
6575               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6576             enddo
6577             do kk=1,2
6578               do ll=1,2
6579                 ind=ind+1
6580                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6581               enddo
6582             enddo
6583             do jj=1,5
6584               do kk=1,3
6585                 do ll=1,2
6586                   do mm=1,2
6587                     ind=ind+1
6588                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6589                   enddo
6590                 enddo
6591               enddo
6592             enddo
6593           endif
6594         enddo
6595         enddo
6596       enddo
6597       if (lprn) then
6598       write (iout,*)
6599      &  "Numbers of contacts to be sent to other processors",
6600      &  (ncont_sent(i),i=1,ntask_cont_to)
6601       write (iout,*) "Contacts sent"
6602       do ii=1,ntask_cont_to
6603         nn=ncont_sent(ii)
6604         iproc=itask_cont_to(ii)
6605         write (iout,*) nn," contacts to processor",iproc,
6606      &   " of CONT_TO_COMM group"
6607         do i=1,nn
6608           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6609         enddo
6610       enddo
6611       call flush(iout)
6612       endif
6613       CorrelType=477
6614       CorrelID=fg_rank+1
6615       CorrelType1=478
6616       CorrelID1=nfgtasks+fg_rank+1
6617       ireq=0
6618 C Receive the numbers of needed contacts from other processors
6619       do ii=1,ntask_cont_from
6620         iproc=itask_cont_from(ii)
6621         ireq=ireq+1
6622         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6623      &    FG_COMM,req(ireq),IERR)
6624       enddo
6625 c      write (iout,*) "IRECV ended"
6626 c      call flush(iout)
6627 C Send the number of contacts needed by other processors
6628       do ii=1,ntask_cont_to
6629         iproc=itask_cont_to(ii)
6630         ireq=ireq+1
6631         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6632      &    FG_COMM,req(ireq),IERR)
6633       enddo
6634 c      write (iout,*) "ISEND ended"
6635 c      write (iout,*) "number of requests (nn)",ireq
6636       call flush(iout)
6637       if (ireq.gt.0)
6638      &  call MPI_Waitall(ireq,req,status_array,ierr)
6639 c      write (iout,*)
6640 c     &  "Numbers of contacts to be received from other processors",
6641 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6642 c      call flush(iout)
6643 C Receive contacts
6644       ireq=0
6645       do ii=1,ntask_cont_from
6646         iproc=itask_cont_from(ii)
6647         nn=ncont_recv(ii)
6648 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6649 c     &   " of CONT_TO_COMM group"
6650         call flush(iout)
6651         if (nn.gt.0) then
6652           ireq=ireq+1
6653           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6654      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6655 c          write (iout,*) "ireq,req",ireq,req(ireq)
6656         endif
6657       enddo
6658 C Send the contacts to processors that need them
6659       do ii=1,ntask_cont_to
6660         iproc=itask_cont_to(ii)
6661         nn=ncont_sent(ii)
6662 c        write (iout,*) nn," contacts to processor",iproc,
6663 c     &   " of CONT_TO_COMM group"
6664         if (nn.gt.0) then
6665           ireq=ireq+1
6666           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6667      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6668 c          write (iout,*) "ireq,req",ireq,req(ireq)
6669 c          do i=1,nn
6670 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6671 c          enddo
6672         endif
6673       enddo
6674 c      write (iout,*) "number of requests (contacts)",ireq
6675 c      write (iout,*) "req",(req(i),i=1,4)
6676 c      call flush(iout)
6677       if (ireq.gt.0)
6678      & call MPI_Waitall(ireq,req,status_array,ierr)
6679       do iii=1,ntask_cont_from
6680         iproc=itask_cont_from(iii)
6681         nn=ncont_recv(iii)
6682         if (lprn) then
6683         write (iout,*) "Received",nn," contacts from processor",iproc,
6684      &   " of CONT_FROM_COMM group"
6685         call flush(iout)
6686         do i=1,nn
6687           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6688         enddo
6689         call flush(iout)
6690         endif
6691         do i=1,nn
6692           ii=zapas_recv(1,i,iii)
6693 c Flag the received contacts to prevent double-counting
6694           jj=-zapas_recv(2,i,iii)
6695 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6696 c          call flush(iout)
6697           nnn=num_cont_hb(ii)+1
6698           num_cont_hb(ii)=nnn
6699           jcont_hb(nnn,ii)=jj
6700           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6701           ind=3
6702           do kk=1,3
6703             ind=ind+1
6704             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6705           enddo
6706           do kk=1,2
6707             do ll=1,2
6708               ind=ind+1
6709               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6710             enddo
6711           enddo
6712           do jj=1,5
6713             do kk=1,3
6714               do ll=1,2
6715                 do mm=1,2
6716                   ind=ind+1
6717                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6718                 enddo
6719               enddo
6720             enddo
6721           enddo
6722         enddo
6723       enddo
6724       call flush(iout)
6725       if (lprn) then
6726         write (iout,'(a)') 'Contact function values after receive:'
6727         do i=nnt,nct-2
6728           write (iout,'(2i3,50(1x,i3,5f6.3))')
6729      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6730      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6731         enddo
6732         call flush(iout)
6733       endif
6734    30 continue
6735 #endif
6736       if (lprn) then
6737         write (iout,'(a)') 'Contact function values:'
6738         do i=nnt,nct-2
6739           write (iout,'(2i3,50(1x,i2,5f6.3))')
6740      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6741      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6742         enddo
6743       endif
6744       ecorr=0.0D0
6745       ecorr5=0.0d0
6746       ecorr6=0.0d0
6747 C Remove the loop below after debugging !!!
6748       do i=nnt,nct
6749         do j=1,3
6750           gradcorr(j,i)=0.0D0
6751           gradxorr(j,i)=0.0D0
6752         enddo
6753       enddo
6754 C Calculate the dipole-dipole interaction energies
6755       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6756       do i=iatel_s,iatel_e+1
6757         num_conti=num_cont_hb(i)
6758         do jj=1,num_conti
6759           j=jcont_hb(jj,i)
6760 #ifdef MOMENT
6761           call dipole(i,j,jj)
6762 #endif
6763         enddo
6764       enddo
6765       endif
6766 C Calculate the local-electrostatic correlation terms
6767 c                write (iout,*) "gradcorr5 in eello5 before loop"
6768 c                do iii=1,nres
6769 c                  write (iout,'(i5,3f10.5)')
6770 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6771 c                enddo
6772       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6773 c        write (iout,*) "corr loop i",i
6774         i1=i+1
6775         num_conti=num_cont_hb(i)
6776         num_conti1=num_cont_hb(i+1)
6777         do jj=1,num_conti
6778           j=jcont_hb(jj,i)
6779           jp=iabs(j)
6780           do kk=1,num_conti1
6781             j1=jcont_hb(kk,i1)
6782             jp1=iabs(j1)
6783 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6784 c     &         ' jj=',jj,' kk=',kk
6785 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6786             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6787      &          .or. j.lt.0 .and. j1.gt.0) .and.
6788      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6789 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6790 C The system gains extra energy.
6791               n_corr=n_corr+1
6792               sqd1=dsqrt(d_cont(jj,i))
6793               sqd2=dsqrt(d_cont(kk,i1))
6794               sred_geom = sqd1*sqd2
6795               IF (sred_geom.lt.cutoff_corr) THEN
6796                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6797      &            ekont,fprimcont)
6798 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6799 cd     &         ' jj=',jj,' kk=',kk
6800                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6801                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6802                 do l=1,3
6803                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6804                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6805                 enddo
6806                 n_corr1=n_corr1+1
6807 cd               write (iout,*) 'sred_geom=',sred_geom,
6808 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6809 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6810 cd               write (iout,*) "g_contij",g_contij
6811 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6812 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6813                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6814                 if (wcorr4.gt.0.0d0)
6815      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6816                   if (energy_dec.and.wcorr4.gt.0.0d0)
6817      1                 write (iout,'(a6,4i5,0pf7.3)')
6818      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6819 c                write (iout,*) "gradcorr5 before eello5"
6820 c                do iii=1,nres
6821 c                  write (iout,'(i5,3f10.5)')
6822 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6823 c                enddo
6824                 if (wcorr5.gt.0.0d0)
6825      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6826 c                write (iout,*) "gradcorr5 after eello5"
6827 c                do iii=1,nres
6828 c                  write (iout,'(i5,3f10.5)')
6829 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6830 c                enddo
6831                   if (energy_dec.and.wcorr5.gt.0.0d0)
6832      1                 write (iout,'(a6,4i5,0pf7.3)')
6833      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6834 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6835 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6836                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6837      &               .or. wturn6.eq.0.0d0))then
6838 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6839                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6840                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6841      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6842 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6843 cd     &            'ecorr6=',ecorr6
6844 cd                write (iout,'(4e15.5)') sred_geom,
6845 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6846 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6847 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6848                 else if (wturn6.gt.0.0d0
6849      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6850 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6851                   eturn6=eturn6+eello_turn6(i,jj,kk)
6852                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6853      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6854 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6855                 endif
6856               ENDIF
6857 1111          continue
6858             endif
6859           enddo ! kk
6860         enddo ! jj
6861       enddo ! i
6862       do i=1,nres
6863         num_cont_hb(i)=num_cont_hb_old(i)
6864       enddo
6865 c                write (iout,*) "gradcorr5 in eello5"
6866 c                do iii=1,nres
6867 c                  write (iout,'(i5,3f10.5)')
6868 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6869 c                enddo
6870       return
6871       end
6872 c------------------------------------------------------------------------------
6873       subroutine add_hb_contact_eello(ii,jj,itask)
6874       implicit real*8 (a-h,o-z)
6875       include "DIMENSIONS"
6876       include "COMMON.IOUNITS"
6877       integer max_cont
6878       integer max_dim
6879       parameter (max_cont=maxconts)
6880       parameter (max_dim=70)
6881       include "COMMON.CONTACTS"
6882       double precision zapas(max_dim,maxconts,max_fg_procs),
6883      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6884       common /przechowalnia/ zapas
6885       integer i,j,ii,jj,iproc,itask(4),nn
6886 c      write (iout,*) "itask",itask
6887       do i=1,2
6888         iproc=itask(i)
6889         if (iproc.gt.0) then
6890           do j=1,num_cont_hb(ii)
6891             jjc=jcont_hb(j,ii)
6892 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6893             if (jjc.eq.jj) then
6894               ncont_sent(iproc)=ncont_sent(iproc)+1
6895               nn=ncont_sent(iproc)
6896               zapas(1,nn,iproc)=ii
6897               zapas(2,nn,iproc)=jjc
6898               zapas(3,nn,iproc)=d_cont(j,ii)
6899               ind=3
6900               do kk=1,3
6901                 ind=ind+1
6902                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6903               enddo
6904               do kk=1,2
6905                 do ll=1,2
6906                   ind=ind+1
6907                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6908                 enddo
6909               enddo
6910               do jj=1,5
6911                 do kk=1,3
6912                   do ll=1,2
6913                     do mm=1,2
6914                       ind=ind+1
6915                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6916                     enddo
6917                   enddo
6918                 enddo
6919               enddo
6920               exit
6921             endif
6922           enddo
6923         endif
6924       enddo
6925       return
6926       end
6927 c------------------------------------------------------------------------------
6928       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6929       implicit real*8 (a-h,o-z)
6930       include 'DIMENSIONS'
6931       include 'COMMON.IOUNITS'
6932       include 'COMMON.DERIV'
6933       include 'COMMON.INTERACT'
6934       include 'COMMON.CONTACTS'
6935       double precision gx(3),gx1(3)
6936       logical lprn
6937       lprn=.false.
6938       eij=facont_hb(jj,i)
6939       ekl=facont_hb(kk,k)
6940       ees0pij=ees0p(jj,i)
6941       ees0pkl=ees0p(kk,k)
6942       ees0mij=ees0m(jj,i)
6943       ees0mkl=ees0m(kk,k)
6944       ekont=eij*ekl
6945       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6946 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6947 C Following 4 lines for diagnostics.
6948 cd    ees0pkl=0.0D0
6949 cd    ees0pij=1.0D0
6950 cd    ees0mkl=0.0D0
6951 cd    ees0mij=1.0D0
6952 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6953 c     & 'Contacts ',i,j,
6954 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6955 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6956 c     & 'gradcorr_long'
6957 C Calculate the multi-body contribution to energy.
6958 c      ecorr=ecorr+ekont*ees
6959 C Calculate multi-body contributions to the gradient.
6960       coeffpees0pij=coeffp*ees0pij
6961       coeffmees0mij=coeffm*ees0mij
6962       coeffpees0pkl=coeffp*ees0pkl
6963       coeffmees0mkl=coeffm*ees0mkl
6964       do ll=1,3
6965 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6966         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6967      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6968      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6969         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6970      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6971      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6972 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6973         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6974      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6975      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6976         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6977      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6978      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6979         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6980      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6981      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6982         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6983         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6984         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6985      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6986      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6987         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6988         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6989 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6990       enddo
6991 c      write (iout,*)
6992 cgrad      do m=i+1,j-1
6993 cgrad        do ll=1,3
6994 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6995 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6996 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6997 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6998 cgrad        enddo
6999 cgrad      enddo
7000 cgrad      do m=k+1,l-1
7001 cgrad        do ll=1,3
7002 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7003 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7004 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7005 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7006 cgrad        enddo
7007 cgrad      enddo
7008 c      write (iout,*) "ehbcorr",ekont*ees
7009       ehbcorr=ekont*ees
7010       return
7011       end
7012 #ifdef MOMENT
7013 C---------------------------------------------------------------------------
7014       subroutine dipole(i,j,jj)
7015       implicit real*8 (a-h,o-z)
7016       include 'DIMENSIONS'
7017       include 'COMMON.IOUNITS'
7018       include 'COMMON.CHAIN'
7019       include 'COMMON.FFIELD'
7020       include 'COMMON.DERIV'
7021       include 'COMMON.INTERACT'
7022       include 'COMMON.CONTACTS'
7023       include 'COMMON.TORSION'
7024       include 'COMMON.VAR'
7025       include 'COMMON.GEO'
7026       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7027      &  auxmat(2,2)
7028       iti1 = itortyp(itype(i+1))
7029       if (j.lt.nres-1) then
7030         itj1 = itortyp(itype(j+1))
7031       else
7032         itj1=ntortyp+1
7033       endif
7034       do iii=1,2
7035         dipi(iii,1)=Ub2(iii,i)
7036         dipderi(iii)=Ub2der(iii,i)
7037         dipi(iii,2)=b1(iii,i+1)
7038         dipj(iii,1)=Ub2(iii,j)
7039         dipderj(iii)=Ub2der(iii,j)
7040         dipj(iii,2)=b1(iii,j+1)
7041       enddo
7042       kkk=0
7043       do iii=1,2
7044         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7045         do jjj=1,2
7046           kkk=kkk+1
7047           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7048         enddo
7049       enddo
7050       do kkk=1,5
7051         do lll=1,3
7052           mmm=0
7053           do iii=1,2
7054             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7055      &        auxvec(1))
7056             do jjj=1,2
7057               mmm=mmm+1
7058               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7059             enddo
7060           enddo
7061         enddo
7062       enddo
7063       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7064       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7065       do iii=1,2
7066         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7067       enddo
7068       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7069       do iii=1,2
7070         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7071       enddo
7072       return
7073       end
7074 #endif
7075 C---------------------------------------------------------------------------
7076       subroutine calc_eello(i,j,k,l,jj,kk)
7077 C
7078 C This subroutine computes matrices and vectors needed to calculate
7079 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7080 C
7081       implicit real*8 (a-h,o-z)
7082       include 'DIMENSIONS'
7083       include 'COMMON.IOUNITS'
7084       include 'COMMON.CHAIN'
7085       include 'COMMON.DERIV'
7086       include 'COMMON.INTERACT'
7087       include 'COMMON.CONTACTS'
7088       include 'COMMON.TORSION'
7089       include 'COMMON.VAR'
7090       include 'COMMON.GEO'
7091       include 'COMMON.FFIELD'
7092       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7093      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7094       logical lprn
7095       common /kutas/ lprn
7096 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7097 cd     & ' jj=',jj,' kk=',kk
7098 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7099 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7100 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7101       do iii=1,2
7102         do jjj=1,2
7103           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7104           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7105         enddo
7106       enddo
7107       call transpose2(aa1(1,1),aa1t(1,1))
7108       call transpose2(aa2(1,1),aa2t(1,1))
7109       do kkk=1,5
7110         do lll=1,3
7111           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7112      &      aa1tder(1,1,lll,kkk))
7113           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7114      &      aa2tder(1,1,lll,kkk))
7115         enddo
7116       enddo
7117       if (l.eq.j+1) then
7118 C parallel orientation of the two CA-CA-CA frames.
7119         if (i.gt.1) then
7120           iti=itortyp(itype(i))
7121         else
7122           iti=ntortyp+1
7123         endif
7124         itk1=itortyp(itype(k+1))
7125         itj=itortyp(itype(j))
7126         if (l.lt.nres-1) then
7127           itl1=itortyp(itype(l+1))
7128         else
7129           itl1=ntortyp+1
7130         endif
7131 C A1 kernel(j+1) A2T
7132 cd        do iii=1,2
7133 cd          write (iout,'(3f10.5,5x,3f10.5)')
7134 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7135 cd        enddo
7136         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7137      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7138      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7139 C Following matrices are needed only for 6-th order cumulants
7140         IF (wcorr6.gt.0.0d0) THEN
7141         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7142      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7143      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7144         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7145      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7146      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7147      &   ADtEAderx(1,1,1,1,1,1))
7148         lprn=.false.
7149         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7150      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7151      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7152      &   ADtEA1derx(1,1,1,1,1,1))
7153         ENDIF
7154 C End 6-th order cumulants
7155 cd        lprn=.false.
7156 cd        if (lprn) then
7157 cd        write (2,*) 'In calc_eello6'
7158 cd        do iii=1,2
7159 cd          write (2,*) 'iii=',iii
7160 cd          do kkk=1,5
7161 cd            write (2,*) 'kkk=',kkk
7162 cd            do jjj=1,2
7163 cd              write (2,'(3(2f10.5),5x)')
7164 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7165 cd            enddo
7166 cd          enddo
7167 cd        enddo
7168 cd        endif
7169         call transpose2(EUgder(1,1,k),auxmat(1,1))
7170         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7171         call transpose2(EUg(1,1,k),auxmat(1,1))
7172         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7173         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7174         do iii=1,2
7175           do kkk=1,5
7176             do lll=1,3
7177               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7178      &          EAEAderx(1,1,lll,kkk,iii,1))
7179             enddo
7180           enddo
7181         enddo
7182 C A1T kernel(i+1) A2
7183         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7184      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7185      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7186 C Following matrices are needed only for 6-th order cumulants
7187         IF (wcorr6.gt.0.0d0) THEN
7188         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7189      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7190      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7191         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7192      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7193      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7194      &   ADtEAderx(1,1,1,1,1,2))
7195         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7196      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7197      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7198      &   ADtEA1derx(1,1,1,1,1,2))
7199         ENDIF
7200 C End 6-th order cumulants
7201         call transpose2(EUgder(1,1,l),auxmat(1,1))
7202         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7203         call transpose2(EUg(1,1,l),auxmat(1,1))
7204         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7205         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7206         do iii=1,2
7207           do kkk=1,5
7208             do lll=1,3
7209               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7210      &          EAEAderx(1,1,lll,kkk,iii,2))
7211             enddo
7212           enddo
7213         enddo
7214 C AEAb1 and AEAb2
7215 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7216 C They are needed only when the fifth- or the sixth-order cumulants are
7217 C indluded.
7218         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7219         call transpose2(AEA(1,1,1),auxmat(1,1))
7220         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7221         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7222         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7223         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7224         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7225         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7226         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7227         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7228         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7229         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7230         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7231         call transpose2(AEA(1,1,2),auxmat(1,1))
7232         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7233         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7234         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7235         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7236         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7237         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7238         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7239         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7240         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7241         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7242         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7243 C Calculate the Cartesian derivatives of the vectors.
7244         do iii=1,2
7245           do kkk=1,5
7246             do lll=1,3
7247               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7248               call matvec2(auxmat(1,1),b1(1,i),
7249      &          AEAb1derx(1,lll,kkk,iii,1,1))
7250               call matvec2(auxmat(1,1),Ub2(1,i),
7251      &          AEAb2derx(1,lll,kkk,iii,1,1))
7252               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7253      &          AEAb1derx(1,lll,kkk,iii,2,1))
7254               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7255      &          AEAb2derx(1,lll,kkk,iii,2,1))
7256               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7257               call matvec2(auxmat(1,1),b1(1,j),
7258      &          AEAb1derx(1,lll,kkk,iii,1,2))
7259               call matvec2(auxmat(1,1),Ub2(1,j),
7260      &          AEAb2derx(1,lll,kkk,iii,1,2))
7261               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7262      &          AEAb1derx(1,lll,kkk,iii,2,2))
7263               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7264      &          AEAb2derx(1,lll,kkk,iii,2,2))
7265             enddo
7266           enddo
7267         enddo
7268         ENDIF
7269 C End vectors
7270       else
7271 C Antiparallel orientation of the two CA-CA-CA frames.
7272         if (i.gt.1) then
7273           iti=itortyp(itype(i))
7274         else
7275           iti=ntortyp+1
7276         endif
7277         itk1=itortyp(itype(k+1))
7278         itl=itortyp(itype(l))
7279         itj=itortyp(itype(j))
7280         if (j.lt.nres-1) then
7281           itj1=itortyp(itype(j+1))
7282         else
7283           itj1=ntortyp+1
7284         endif
7285 C A2 kernel(j-1)T A1T
7286         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7287      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7288      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7289 C Following matrices are needed only for 6-th order cumulants
7290         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7291      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7292         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7293      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7294      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7295         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7296      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7297      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7298      &   ADtEAderx(1,1,1,1,1,1))
7299         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7300      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7301      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7302      &   ADtEA1derx(1,1,1,1,1,1))
7303         ENDIF
7304 C End 6-th order cumulants
7305         call transpose2(EUgder(1,1,k),auxmat(1,1))
7306         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7307         call transpose2(EUg(1,1,k),auxmat(1,1))
7308         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7309         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7310         do iii=1,2
7311           do kkk=1,5
7312             do lll=1,3
7313               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7314      &          EAEAderx(1,1,lll,kkk,iii,1))
7315             enddo
7316           enddo
7317         enddo
7318 C A2T kernel(i+1)T A1
7319         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7320      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7321      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7322 C Following matrices are needed only for 6-th order cumulants
7323         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7324      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7325         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7326      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7327      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7328         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7329      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7330      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7331      &   ADtEAderx(1,1,1,1,1,2))
7332         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7333      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7334      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7335      &   ADtEA1derx(1,1,1,1,1,2))
7336         ENDIF
7337 C End 6-th order cumulants
7338         call transpose2(EUgder(1,1,j),auxmat(1,1))
7339         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7340         call transpose2(EUg(1,1,j),auxmat(1,1))
7341         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7342         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7343         do iii=1,2
7344           do kkk=1,5
7345             do lll=1,3
7346               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7347      &          EAEAderx(1,1,lll,kkk,iii,2))
7348             enddo
7349           enddo
7350         enddo
7351 C AEAb1 and AEAb2
7352 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7353 C They are needed only when the fifth- or the sixth-order cumulants are
7354 C indluded.
7355         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7356      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7357         call transpose2(AEA(1,1,1),auxmat(1,1))
7358         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7359         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7360         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7361         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7362         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7363         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7364         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7365         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7366         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7367         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7368         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7369         call transpose2(AEA(1,1,2),auxmat(1,1))
7370         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7371         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7372         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7373         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7374         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7375         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7376         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7377         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7378         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7379         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7380         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7381 C Calculate the Cartesian derivatives of the vectors.
7382         do iii=1,2
7383           do kkk=1,5
7384             do lll=1,3
7385               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7386               call matvec2(auxmat(1,1),b1(1,i),
7387      &          AEAb1derx(1,lll,kkk,iii,1,1))
7388               call matvec2(auxmat(1,1),Ub2(1,i),
7389      &          AEAb2derx(1,lll,kkk,iii,1,1))
7390               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7391      &          AEAb1derx(1,lll,kkk,iii,2,1))
7392               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7393      &          AEAb2derx(1,lll,kkk,iii,2,1))
7394               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7395               call matvec2(auxmat(1,1),b1(1,l),
7396      &          AEAb1derx(1,lll,kkk,iii,1,2))
7397               call matvec2(auxmat(1,1),Ub2(1,l),
7398      &          AEAb2derx(1,lll,kkk,iii,1,2))
7399               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7400      &          AEAb1derx(1,lll,kkk,iii,2,2))
7401               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7402      &          AEAb2derx(1,lll,kkk,iii,2,2))
7403             enddo
7404           enddo
7405         enddo
7406         ENDIF
7407 C End vectors
7408       endif
7409       return
7410       end
7411 C---------------------------------------------------------------------------
7412       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7413      &  KK,KKderg,AKA,AKAderg,AKAderx)
7414       implicit none
7415       integer nderg
7416       logical transp
7417       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7418      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7419      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7420       integer iii,kkk,lll
7421       integer jjj,mmm
7422       logical lprn
7423       common /kutas/ lprn
7424       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7425       do iii=1,nderg
7426         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7427      &    AKAderg(1,1,iii))
7428       enddo
7429 cd      if (lprn) write (2,*) 'In kernel'
7430       do kkk=1,5
7431 cd        if (lprn) write (2,*) 'kkk=',kkk
7432         do lll=1,3
7433           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7434      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7435 cd          if (lprn) then
7436 cd            write (2,*) 'lll=',lll
7437 cd            write (2,*) 'iii=1'
7438 cd            do jjj=1,2
7439 cd              write (2,'(3(2f10.5),5x)')
7440 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7441 cd            enddo
7442 cd          endif
7443           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7444      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7445 cd          if (lprn) then
7446 cd            write (2,*) 'lll=',lll
7447 cd            write (2,*) 'iii=2'
7448 cd            do jjj=1,2
7449 cd              write (2,'(3(2f10.5),5x)')
7450 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7451 cd            enddo
7452 cd          endif
7453         enddo
7454       enddo
7455       return
7456       end
7457 C---------------------------------------------------------------------------
7458       double precision function eello4(i,j,k,l,jj,kk)
7459       implicit real*8 (a-h,o-z)
7460       include 'DIMENSIONS'
7461       include 'COMMON.IOUNITS'
7462       include 'COMMON.CHAIN'
7463       include 'COMMON.DERIV'
7464       include 'COMMON.INTERACT'
7465       include 'COMMON.CONTACTS'
7466       include 'COMMON.TORSION'
7467       include 'COMMON.VAR'
7468       include 'COMMON.GEO'
7469       double precision pizda(2,2),ggg1(3),ggg2(3)
7470 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7471 cd        eello4=0.0d0
7472 cd        return
7473 cd      endif
7474 cd      print *,'eello4:',i,j,k,l,jj,kk
7475 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7476 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7477 cold      eij=facont_hb(jj,i)
7478 cold      ekl=facont_hb(kk,k)
7479 cold      ekont=eij*ekl
7480       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7481 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7482       gcorr_loc(k-1)=gcorr_loc(k-1)
7483      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7484       if (l.eq.j+1) then
7485         gcorr_loc(l-1)=gcorr_loc(l-1)
7486      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7487       else
7488         gcorr_loc(j-1)=gcorr_loc(j-1)
7489      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7490       endif
7491       do iii=1,2
7492         do kkk=1,5
7493           do lll=1,3
7494             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7495      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7496 cd            derx(lll,kkk,iii)=0.0d0
7497           enddo
7498         enddo
7499       enddo
7500 cd      gcorr_loc(l-1)=0.0d0
7501 cd      gcorr_loc(j-1)=0.0d0
7502 cd      gcorr_loc(k-1)=0.0d0
7503 cd      eel4=1.0d0
7504 cd      write (iout,*)'Contacts have occurred for peptide groups',
7505 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7506 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7507       if (j.lt.nres-1) then
7508         j1=j+1
7509         j2=j-1
7510       else
7511         j1=j-1
7512         j2=j-2
7513       endif
7514       if (l.lt.nres-1) then
7515         l1=l+1
7516         l2=l-1
7517       else
7518         l1=l-1
7519         l2=l-2
7520       endif
7521       do ll=1,3
7522 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7523 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7524         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7525         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7526 cgrad        ghalf=0.5d0*ggg1(ll)
7527         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7528         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7529         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7530         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7531         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7532         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7533 cgrad        ghalf=0.5d0*ggg2(ll)
7534         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7535         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7536         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7537         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7538         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7539         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7540       enddo
7541 cgrad      do m=i+1,j-1
7542 cgrad        do ll=1,3
7543 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7544 cgrad        enddo
7545 cgrad      enddo
7546 cgrad      do m=k+1,l-1
7547 cgrad        do ll=1,3
7548 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7549 cgrad        enddo
7550 cgrad      enddo
7551 cgrad      do m=i+2,j2
7552 cgrad        do ll=1,3
7553 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7554 cgrad        enddo
7555 cgrad      enddo
7556 cgrad      do m=k+2,l2
7557 cgrad        do ll=1,3
7558 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7559 cgrad        enddo
7560 cgrad      enddo
7561 cd      do iii=1,nres-3
7562 cd        write (2,*) iii,gcorr_loc(iii)
7563 cd      enddo
7564       eello4=ekont*eel4
7565 cd      write (2,*) 'ekont',ekont
7566 cd      write (iout,*) 'eello4',ekont*eel4
7567       return
7568       end
7569 C---------------------------------------------------------------------------
7570       double precision function eello5(i,j,k,l,jj,kk)
7571       implicit real*8 (a-h,o-z)
7572       include 'DIMENSIONS'
7573       include 'COMMON.IOUNITS'
7574       include 'COMMON.CHAIN'
7575       include 'COMMON.DERIV'
7576       include 'COMMON.INTERACT'
7577       include 'COMMON.CONTACTS'
7578       include 'COMMON.TORSION'
7579       include 'COMMON.VAR'
7580       include 'COMMON.GEO'
7581       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7582       double precision ggg1(3),ggg2(3)
7583 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7584 C                                                                              C
7585 C                            Parallel chains                                   C
7586 C                                                                              C
7587 C          o             o                   o             o                   C
7588 C         /l\           / \             \   / \           / \   /              C
7589 C        /   \         /   \             \ /   \         /   \ /               C
7590 C       j| o |l1       | o |              o| o |         | o |o                C
7591 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7592 C      \i/   \         /   \ /             /   \         /   \                 C
7593 C       o    k1             o                                                  C
7594 C         (I)          (II)                (III)          (IV)                 C
7595 C                                                                              C
7596 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7597 C                                                                              C
7598 C                            Antiparallel chains                               C
7599 C                                                                              C
7600 C          o             o                   o             o                   C
7601 C         /j\           / \             \   / \           / \   /              C
7602 C        /   \         /   \             \ /   \         /   \ /               C
7603 C      j1| o |l        | o |              o| o |         | o |o                C
7604 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7605 C      \i/   \         /   \ /             /   \         /   \                 C
7606 C       o     k1            o                                                  C
7607 C         (I)          (II)                (III)          (IV)                 C
7608 C                                                                              C
7609 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7610 C                                                                              C
7611 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7612 C                                                                              C
7613 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7614 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7615 cd        eello5=0.0d0
7616 cd        return
7617 cd      endif
7618 cd      write (iout,*)
7619 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7620 cd     &   ' and',k,l
7621       itk=itortyp(itype(k))
7622       itl=itortyp(itype(l))
7623       itj=itortyp(itype(j))
7624       eello5_1=0.0d0
7625       eello5_2=0.0d0
7626       eello5_3=0.0d0
7627       eello5_4=0.0d0
7628 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7629 cd     &   eel5_3_num,eel5_4_num)
7630       do iii=1,2
7631         do kkk=1,5
7632           do lll=1,3
7633             derx(lll,kkk,iii)=0.0d0
7634           enddo
7635         enddo
7636       enddo
7637 cd      eij=facont_hb(jj,i)
7638 cd      ekl=facont_hb(kk,k)
7639 cd      ekont=eij*ekl
7640 cd      write (iout,*)'Contacts have occurred for peptide groups',
7641 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7642 cd      goto 1111
7643 C Contribution from the graph I.
7644 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7645 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7646       call transpose2(EUg(1,1,k),auxmat(1,1))
7647       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7648       vv(1)=pizda(1,1)-pizda(2,2)
7649       vv(2)=pizda(1,2)+pizda(2,1)
7650       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7651      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7652 C Explicit gradient in virtual-dihedral angles.
7653       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7654      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7655      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7656       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7657       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7658       vv(1)=pizda(1,1)-pizda(2,2)
7659       vv(2)=pizda(1,2)+pizda(2,1)
7660       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7661      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7662      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7663       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7664       vv(1)=pizda(1,1)-pizda(2,2)
7665       vv(2)=pizda(1,2)+pizda(2,1)
7666       if (l.eq.j+1) then
7667         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7668      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7669      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7670       else
7671         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7672      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7673      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7674       endif
7675 C Cartesian gradient
7676       do iii=1,2
7677         do kkk=1,5
7678           do lll=1,3
7679             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7680      &        pizda(1,1))
7681             vv(1)=pizda(1,1)-pizda(2,2)
7682             vv(2)=pizda(1,2)+pizda(2,1)
7683             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7684      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7685      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7686           enddo
7687         enddo
7688       enddo
7689 c      goto 1112
7690 c1111  continue
7691 C Contribution from graph II
7692       call transpose2(EE(1,1,itk),auxmat(1,1))
7693       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7694       vv(1)=pizda(1,1)+pizda(2,2)
7695       vv(2)=pizda(2,1)-pizda(1,2)
7696       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7697      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7698 C Explicit gradient in virtual-dihedral angles.
7699       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7700      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7701       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7702       vv(1)=pizda(1,1)+pizda(2,2)
7703       vv(2)=pizda(2,1)-pizda(1,2)
7704       if (l.eq.j+1) then
7705         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7706      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7707      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7708       else
7709         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7710      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7711      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7712       endif
7713 C Cartesian gradient
7714       do iii=1,2
7715         do kkk=1,5
7716           do lll=1,3
7717             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7718      &        pizda(1,1))
7719             vv(1)=pizda(1,1)+pizda(2,2)
7720             vv(2)=pizda(2,1)-pizda(1,2)
7721             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7722      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7723      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7724           enddo
7725         enddo
7726       enddo
7727 cd      goto 1112
7728 cd1111  continue
7729       if (l.eq.j+1) then
7730 cd        goto 1110
7731 C Parallel orientation
7732 C Contribution from graph III
7733         call transpose2(EUg(1,1,l),auxmat(1,1))
7734         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7735         vv(1)=pizda(1,1)-pizda(2,2)
7736         vv(2)=pizda(1,2)+pizda(2,1)
7737         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7738      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7739 C Explicit gradient in virtual-dihedral angles.
7740         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7741      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7742      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7743         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7744         vv(1)=pizda(1,1)-pizda(2,2)
7745         vv(2)=pizda(1,2)+pizda(2,1)
7746         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7747      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7748      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7749         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7750         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7751         vv(1)=pizda(1,1)-pizda(2,2)
7752         vv(2)=pizda(1,2)+pizda(2,1)
7753         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7754      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7755      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7756 C Cartesian gradient
7757         do iii=1,2
7758           do kkk=1,5
7759             do lll=1,3
7760               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7761      &          pizda(1,1))
7762               vv(1)=pizda(1,1)-pizda(2,2)
7763               vv(2)=pizda(1,2)+pizda(2,1)
7764               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7765      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7766      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7767             enddo
7768           enddo
7769         enddo
7770 cd        goto 1112
7771 C Contribution from graph IV
7772 cd1110    continue
7773         call transpose2(EE(1,1,itl),auxmat(1,1))
7774         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7775         vv(1)=pizda(1,1)+pizda(2,2)
7776         vv(2)=pizda(2,1)-pizda(1,2)
7777         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7778      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7779 C Explicit gradient in virtual-dihedral angles.
7780         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7781      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7782         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7783         vv(1)=pizda(1,1)+pizda(2,2)
7784         vv(2)=pizda(2,1)-pizda(1,2)
7785         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7786      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7787      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7788 C Cartesian gradient
7789         do iii=1,2
7790           do kkk=1,5
7791             do lll=1,3
7792               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7793      &          pizda(1,1))
7794               vv(1)=pizda(1,1)+pizda(2,2)
7795               vv(2)=pizda(2,1)-pizda(1,2)
7796               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7797      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7798      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7799             enddo
7800           enddo
7801         enddo
7802       else
7803 C Antiparallel orientation
7804 C Contribution from graph III
7805 c        goto 1110
7806         call transpose2(EUg(1,1,j),auxmat(1,1))
7807         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7808         vv(1)=pizda(1,1)-pizda(2,2)
7809         vv(2)=pizda(1,2)+pizda(2,1)
7810         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7811      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7812 C Explicit gradient in virtual-dihedral angles.
7813         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7814      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7815      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7816         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7817         vv(1)=pizda(1,1)-pizda(2,2)
7818         vv(2)=pizda(1,2)+pizda(2,1)
7819         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7820      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7821      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7822         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7823         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7824         vv(1)=pizda(1,1)-pizda(2,2)
7825         vv(2)=pizda(1,2)+pizda(2,1)
7826         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7827      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7828      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7829 C Cartesian gradient
7830         do iii=1,2
7831           do kkk=1,5
7832             do lll=1,3
7833               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7834      &          pizda(1,1))
7835               vv(1)=pizda(1,1)-pizda(2,2)
7836               vv(2)=pizda(1,2)+pizda(2,1)
7837               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7838      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7839      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7840             enddo
7841           enddo
7842         enddo
7843 cd        goto 1112
7844 C Contribution from graph IV
7845 1110    continue
7846         call transpose2(EE(1,1,itj),auxmat(1,1))
7847         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7848         vv(1)=pizda(1,1)+pizda(2,2)
7849         vv(2)=pizda(2,1)-pizda(1,2)
7850         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7851      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7852 C Explicit gradient in virtual-dihedral angles.
7853         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7854      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7855         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7856         vv(1)=pizda(1,1)+pizda(2,2)
7857         vv(2)=pizda(2,1)-pizda(1,2)
7858         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7859      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7860      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7861 C Cartesian gradient
7862         do iii=1,2
7863           do kkk=1,5
7864             do lll=1,3
7865               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7866      &          pizda(1,1))
7867               vv(1)=pizda(1,1)+pizda(2,2)
7868               vv(2)=pizda(2,1)-pizda(1,2)
7869               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7870      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7871      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7872             enddo
7873           enddo
7874         enddo
7875       endif
7876 1112  continue
7877       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7878 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7879 cd        write (2,*) 'ijkl',i,j,k,l
7880 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7881 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7882 cd      endif
7883 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7884 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7885 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7886 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7887       if (j.lt.nres-1) then
7888         j1=j+1
7889         j2=j-1
7890       else
7891         j1=j-1
7892         j2=j-2
7893       endif
7894       if (l.lt.nres-1) then
7895         l1=l+1
7896         l2=l-1
7897       else
7898         l1=l-1
7899         l2=l-2
7900       endif
7901 cd      eij=1.0d0
7902 cd      ekl=1.0d0
7903 cd      ekont=1.0d0
7904 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7905 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7906 C        summed up outside the subrouine as for the other subroutines
7907 C        handling long-range interactions. The old code is commented out
7908 C        with "cgrad" to keep track of changes.
7909       do ll=1,3
7910 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7911 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7912         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7913         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7914 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7915 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7916 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7917 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7918 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7919 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7920 c     &   gradcorr5ij,
7921 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7922 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7923 cgrad        ghalf=0.5d0*ggg1(ll)
7924 cd        ghalf=0.0d0
7925         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7926         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7927         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7928         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7929         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7930         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7931 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7932 cgrad        ghalf=0.5d0*ggg2(ll)
7933 cd        ghalf=0.0d0
7934         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7935         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7936         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7937         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7938         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7939         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7940       enddo
7941 cd      goto 1112
7942 cgrad      do m=i+1,j-1
7943 cgrad        do ll=1,3
7944 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7945 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7946 cgrad        enddo
7947 cgrad      enddo
7948 cgrad      do m=k+1,l-1
7949 cgrad        do ll=1,3
7950 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7951 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7952 cgrad        enddo
7953 cgrad      enddo
7954 c1112  continue
7955 cgrad      do m=i+2,j2
7956 cgrad        do ll=1,3
7957 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7958 cgrad        enddo
7959 cgrad      enddo
7960 cgrad      do m=k+2,l2
7961 cgrad        do ll=1,3
7962 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7963 cgrad        enddo
7964 cgrad      enddo
7965 cd      do iii=1,nres-3
7966 cd        write (2,*) iii,g_corr5_loc(iii)
7967 cd      enddo
7968       eello5=ekont*eel5
7969 cd      write (2,*) 'ekont',ekont
7970 cd      write (iout,*) 'eello5',ekont*eel5
7971       return
7972       end
7973 c--------------------------------------------------------------------------
7974       double precision function eello6(i,j,k,l,jj,kk)
7975       implicit real*8 (a-h,o-z)
7976       include 'DIMENSIONS'
7977       include 'COMMON.IOUNITS'
7978       include 'COMMON.CHAIN'
7979       include 'COMMON.DERIV'
7980       include 'COMMON.INTERACT'
7981       include 'COMMON.CONTACTS'
7982       include 'COMMON.TORSION'
7983       include 'COMMON.VAR'
7984       include 'COMMON.GEO'
7985       include 'COMMON.FFIELD'
7986       double precision ggg1(3),ggg2(3)
7987 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7988 cd        eello6=0.0d0
7989 cd        return
7990 cd      endif
7991 cd      write (iout,*)
7992 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7993 cd     &   ' and',k,l
7994       eello6_1=0.0d0
7995       eello6_2=0.0d0
7996       eello6_3=0.0d0
7997       eello6_4=0.0d0
7998       eello6_5=0.0d0
7999       eello6_6=0.0d0
8000 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8001 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8002       do iii=1,2
8003         do kkk=1,5
8004           do lll=1,3
8005             derx(lll,kkk,iii)=0.0d0
8006           enddo
8007         enddo
8008       enddo
8009 cd      eij=facont_hb(jj,i)
8010 cd      ekl=facont_hb(kk,k)
8011 cd      ekont=eij*ekl
8012 cd      eij=1.0d0
8013 cd      ekl=1.0d0
8014 cd      ekont=1.0d0
8015       if (l.eq.j+1) then
8016         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8017         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8018         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8019         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8020         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8021         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8022       else
8023         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8024         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8025         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8026         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8027         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8028           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8029         else
8030           eello6_5=0.0d0
8031         endif
8032         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8033       endif
8034 C If turn contributions are considered, they will be handled separately.
8035       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8036 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8037 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8038 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8039 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8040 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8041 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8042 cd      goto 1112
8043       if (j.lt.nres-1) then
8044         j1=j+1
8045         j2=j-1
8046       else
8047         j1=j-1
8048         j2=j-2
8049       endif
8050       if (l.lt.nres-1) then
8051         l1=l+1
8052         l2=l-1
8053       else
8054         l1=l-1
8055         l2=l-2
8056       endif
8057       do ll=1,3
8058 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8059 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8060 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8061 cgrad        ghalf=0.5d0*ggg1(ll)
8062 cd        ghalf=0.0d0
8063         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8064         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8065         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8066         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8067         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8068         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8069         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8070         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8071 cgrad        ghalf=0.5d0*ggg2(ll)
8072 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8073 cd        ghalf=0.0d0
8074         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8075         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8076         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8077         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8078         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8079         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8080       enddo
8081 cd      goto 1112
8082 cgrad      do m=i+1,j-1
8083 cgrad        do ll=1,3
8084 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8085 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8086 cgrad        enddo
8087 cgrad      enddo
8088 cgrad      do m=k+1,l-1
8089 cgrad        do ll=1,3
8090 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8091 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8092 cgrad        enddo
8093 cgrad      enddo
8094 cgrad1112  continue
8095 cgrad      do m=i+2,j2
8096 cgrad        do ll=1,3
8097 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8098 cgrad        enddo
8099 cgrad      enddo
8100 cgrad      do m=k+2,l2
8101 cgrad        do ll=1,3
8102 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8103 cgrad        enddo
8104 cgrad      enddo
8105 cd      do iii=1,nres-3
8106 cd        write (2,*) iii,g_corr6_loc(iii)
8107 cd      enddo
8108       eello6=ekont*eel6
8109 cd      write (2,*) 'ekont',ekont
8110 cd      write (iout,*) 'eello6',ekont*eel6
8111       return
8112       end
8113 c--------------------------------------------------------------------------
8114       double precision function eello6_graph1(i,j,k,l,imat,swap)
8115       implicit real*8 (a-h,o-z)
8116       include 'DIMENSIONS'
8117       include 'COMMON.IOUNITS'
8118       include 'COMMON.CHAIN'
8119       include 'COMMON.DERIV'
8120       include 'COMMON.INTERACT'
8121       include 'COMMON.CONTACTS'
8122       include 'COMMON.TORSION'
8123       include 'COMMON.VAR'
8124       include 'COMMON.GEO'
8125       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8126       logical swap
8127       logical lprn
8128       common /kutas/ lprn
8129 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8130 C                                                                              C
8131 C      Parallel       Antiparallel                                             C
8132 C                                                                              C
8133 C          o             o                                                     C
8134 C         /l\           /j\                                                    C
8135 C        /   \         /   \                                                   C
8136 C       /| o |         | o |\                                                  C
8137 C     \ j|/k\|  /   \  |/k\|l /                                                C
8138 C      \ /   \ /     \ /   \ /                                                 C
8139 C       o     o       o     o                                                  C
8140 C       i             i                                                        C
8141 C                                                                              C
8142 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8143       itk=itortyp(itype(k))
8144       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8145       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8146       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8147       call transpose2(EUgC(1,1,k),auxmat(1,1))
8148       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8149       vv1(1)=pizda1(1,1)-pizda1(2,2)
8150       vv1(2)=pizda1(1,2)+pizda1(2,1)
8151       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8152       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8153       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8154       s5=scalar2(vv(1),Dtobr2(1,i))
8155 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8156       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8157       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8158      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8159      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8160      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8161      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8162      & +scalar2(vv(1),Dtobr2der(1,i)))
8163       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8164       vv1(1)=pizda1(1,1)-pizda1(2,2)
8165       vv1(2)=pizda1(1,2)+pizda1(2,1)
8166       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8167       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8168       if (l.eq.j+1) then
8169         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8170      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8171      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8172      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8173      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8174       else
8175         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8176      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8177      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8178      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8179      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8180       endif
8181       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8182       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8183       vv1(1)=pizda1(1,1)-pizda1(2,2)
8184       vv1(2)=pizda1(1,2)+pizda1(2,1)
8185       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8186      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8187      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8188      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8189       do iii=1,2
8190         if (swap) then
8191           ind=3-iii
8192         else
8193           ind=iii
8194         endif
8195         do kkk=1,5
8196           do lll=1,3
8197             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8198             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8199             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8200             call transpose2(EUgC(1,1,k),auxmat(1,1))
8201             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8202      &        pizda1(1,1))
8203             vv1(1)=pizda1(1,1)-pizda1(2,2)
8204             vv1(2)=pizda1(1,2)+pizda1(2,1)
8205             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8206             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8207      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8208             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8209      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8210             s5=scalar2(vv(1),Dtobr2(1,i))
8211             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8212           enddo
8213         enddo
8214       enddo
8215       return
8216       end
8217 c----------------------------------------------------------------------------
8218       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8219       implicit real*8 (a-h,o-z)
8220       include 'DIMENSIONS'
8221       include 'COMMON.IOUNITS'
8222       include 'COMMON.CHAIN'
8223       include 'COMMON.DERIV'
8224       include 'COMMON.INTERACT'
8225       include 'COMMON.CONTACTS'
8226       include 'COMMON.TORSION'
8227       include 'COMMON.VAR'
8228       include 'COMMON.GEO'
8229       logical swap
8230       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8231      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8232       logical lprn
8233       common /kutas/ lprn
8234 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8235 C                                                                              C
8236 C      Parallel       Antiparallel                                             C
8237 C                                                                              C
8238 C          o             o                                                     C
8239 C     \   /l\           /j\   /                                                C
8240 C      \ /   \         /   \ /                                                 C
8241 C       o| o |         | o |o                                                  C
8242 C     \ j|/k\|      \  |/k\|l                                                  C
8243 C      \ /   \       \ /   \                                                   C
8244 C       o             o                                                        C
8245 C       i             i                                                        C
8246 C                                                                              C
8247 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8248 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8249 C AL 7/4/01 s1 would occur in the sixth-order moment,
8250 C           but not in a cluster cumulant
8251 #ifdef MOMENT
8252       s1=dip(1,jj,i)*dip(1,kk,k)
8253 #endif
8254       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8255       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8256       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8257       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8258       call transpose2(EUg(1,1,k),auxmat(1,1))
8259       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8260       vv(1)=pizda(1,1)-pizda(2,2)
8261       vv(2)=pizda(1,2)+pizda(2,1)
8262       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8263 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8264 #ifdef MOMENT
8265       eello6_graph2=-(s1+s2+s3+s4)
8266 #else
8267       eello6_graph2=-(s2+s3+s4)
8268 #endif
8269 c      eello6_graph2=-s3
8270 C Derivatives in gamma(i-1)
8271       if (i.gt.1) then
8272 #ifdef MOMENT
8273         s1=dipderg(1,jj,i)*dip(1,kk,k)
8274 #endif
8275         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8276         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8277         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8278         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8279 #ifdef MOMENT
8280         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8281 #else
8282         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8283 #endif
8284 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8285       endif
8286 C Derivatives in gamma(k-1)
8287 #ifdef MOMENT
8288       s1=dip(1,jj,i)*dipderg(1,kk,k)
8289 #endif
8290       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8291       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8292       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8293       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8294       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8295       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8296       vv(1)=pizda(1,1)-pizda(2,2)
8297       vv(2)=pizda(1,2)+pizda(2,1)
8298       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8299 #ifdef MOMENT
8300       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8301 #else
8302       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8303 #endif
8304 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8305 C Derivatives in gamma(j-1) or gamma(l-1)
8306       if (j.gt.1) then
8307 #ifdef MOMENT
8308         s1=dipderg(3,jj,i)*dip(1,kk,k)
8309 #endif
8310         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8311         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8312         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8313         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8314         vv(1)=pizda(1,1)-pizda(2,2)
8315         vv(2)=pizda(1,2)+pizda(2,1)
8316         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8317 #ifdef MOMENT
8318         if (swap) then
8319           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8320         else
8321           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8322         endif
8323 #endif
8324         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8325 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8326       endif
8327 C Derivatives in gamma(l-1) or gamma(j-1)
8328       if (l.gt.1) then
8329 #ifdef MOMENT
8330         s1=dip(1,jj,i)*dipderg(3,kk,k)
8331 #endif
8332         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8333         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8334         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8335         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8336         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8337         vv(1)=pizda(1,1)-pizda(2,2)
8338         vv(2)=pizda(1,2)+pizda(2,1)
8339         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8340 #ifdef MOMENT
8341         if (swap) then
8342           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8343         else
8344           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8345         endif
8346 #endif
8347         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8348 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8349       endif
8350 C Cartesian derivatives.
8351       if (lprn) then
8352         write (2,*) 'In eello6_graph2'
8353         do iii=1,2
8354           write (2,*) 'iii=',iii
8355           do kkk=1,5
8356             write (2,*) 'kkk=',kkk
8357             do jjj=1,2
8358               write (2,'(3(2f10.5),5x)')
8359      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8360             enddo
8361           enddo
8362         enddo
8363       endif
8364       do iii=1,2
8365         do kkk=1,5
8366           do lll=1,3
8367 #ifdef MOMENT
8368             if (iii.eq.1) then
8369               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8370             else
8371               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8372             endif
8373 #endif
8374             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8375      &        auxvec(1))
8376             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8377             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8378      &        auxvec(1))
8379             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8380             call transpose2(EUg(1,1,k),auxmat(1,1))
8381             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8382      &        pizda(1,1))
8383             vv(1)=pizda(1,1)-pizda(2,2)
8384             vv(2)=pizda(1,2)+pizda(2,1)
8385             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8386 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8387 #ifdef MOMENT
8388             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8389 #else
8390             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8391 #endif
8392             if (swap) then
8393               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8394             else
8395               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8396             endif
8397           enddo
8398         enddo
8399       enddo
8400       return
8401       end
8402 c----------------------------------------------------------------------------
8403       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8404       implicit real*8 (a-h,o-z)
8405       include 'DIMENSIONS'
8406       include 'COMMON.IOUNITS'
8407       include 'COMMON.CHAIN'
8408       include 'COMMON.DERIV'
8409       include 'COMMON.INTERACT'
8410       include 'COMMON.CONTACTS'
8411       include 'COMMON.TORSION'
8412       include 'COMMON.VAR'
8413       include 'COMMON.GEO'
8414       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8415       logical swap
8416 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8417 C                                                                              C
8418 C      Parallel       Antiparallel                                             C
8419 C                                                                              C
8420 C          o             o                                                     C
8421 C         /l\   /   \   /j\                                                    C
8422 C        /   \ /     \ /   \                                                   C
8423 C       /| o |o       o| o |\                                                  C
8424 C       j|/k\|  /      |/k\|l /                                                C
8425 C        /   \ /       /   \ /                                                 C
8426 C       /     o       /     o                                                  C
8427 C       i             i                                                        C
8428 C                                                                              C
8429 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8430 C
8431 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8432 C           energy moment and not to the cluster cumulant.
8433       iti=itortyp(itype(i))
8434       if (j.lt.nres-1) then
8435         itj1=itortyp(itype(j+1))
8436       else
8437         itj1=ntortyp+1
8438       endif
8439       itk=itortyp(itype(k))
8440       itk1=itortyp(itype(k+1))
8441       if (l.lt.nres-1) then
8442         itl1=itortyp(itype(l+1))
8443       else
8444         itl1=ntortyp+1
8445       endif
8446 #ifdef MOMENT
8447       s1=dip(4,jj,i)*dip(4,kk,k)
8448 #endif
8449       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8450       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8451       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8452       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8453       call transpose2(EE(1,1,itk),auxmat(1,1))
8454       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8455       vv(1)=pizda(1,1)+pizda(2,2)
8456       vv(2)=pizda(2,1)-pizda(1,2)
8457       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8458 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8459 cd     & "sum",-(s2+s3+s4)
8460 #ifdef MOMENT
8461       eello6_graph3=-(s1+s2+s3+s4)
8462 #else
8463       eello6_graph3=-(s2+s3+s4)
8464 #endif
8465 c      eello6_graph3=-s4
8466 C Derivatives in gamma(k-1)
8467       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8468       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8469       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8470       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8471 C Derivatives in gamma(l-1)
8472       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8473       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8474       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8475       vv(1)=pizda(1,1)+pizda(2,2)
8476       vv(2)=pizda(2,1)-pizda(1,2)
8477       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8478       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8479 C Cartesian derivatives.
8480       do iii=1,2
8481         do kkk=1,5
8482           do lll=1,3
8483 #ifdef MOMENT
8484             if (iii.eq.1) then
8485               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8486             else
8487               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8488             endif
8489 #endif
8490             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8491      &        auxvec(1))
8492             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8493             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8494      &        auxvec(1))
8495             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8496             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8497      &        pizda(1,1))
8498             vv(1)=pizda(1,1)+pizda(2,2)
8499             vv(2)=pizda(2,1)-pizda(1,2)
8500             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8501 #ifdef MOMENT
8502             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8503 #else
8504             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8505 #endif
8506             if (swap) then
8507               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8508             else
8509               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8510             endif
8511 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8512           enddo
8513         enddo
8514       enddo
8515       return
8516       end
8517 c----------------------------------------------------------------------------
8518       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8519       implicit real*8 (a-h,o-z)
8520       include 'DIMENSIONS'
8521       include 'COMMON.IOUNITS'
8522       include 'COMMON.CHAIN'
8523       include 'COMMON.DERIV'
8524       include 'COMMON.INTERACT'
8525       include 'COMMON.CONTACTS'
8526       include 'COMMON.TORSION'
8527       include 'COMMON.VAR'
8528       include 'COMMON.GEO'
8529       include 'COMMON.FFIELD'
8530       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8531      & auxvec1(2),auxmat1(2,2)
8532       logical swap
8533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8534 C                                                                              C
8535 C      Parallel       Antiparallel                                             C
8536 C                                                                              C
8537 C          o             o                                                     C
8538 C         /l\   /   \   /j\                                                    C
8539 C        /   \ /     \ /   \                                                   C
8540 C       /| o |o       o| o |\                                                  C
8541 C     \ j|/k\|      \  |/k\|l                                                  C
8542 C      \ /   \       \ /   \                                                   C
8543 C       o     \       o     \                                                  C
8544 C       i             i                                                        C
8545 C                                                                              C
8546 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8547 C
8548 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8549 C           energy moment and not to the cluster cumulant.
8550 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8551       iti=itortyp(itype(i))
8552       itj=itortyp(itype(j))
8553       if (j.lt.nres-1) then
8554         itj1=itortyp(itype(j+1))
8555       else
8556         itj1=ntortyp+1
8557       endif
8558       itk=itortyp(itype(k))
8559       if (k.lt.nres-1) then
8560         itk1=itortyp(itype(k+1))
8561       else
8562         itk1=ntortyp+1
8563       endif
8564       itl=itortyp(itype(l))
8565       if (l.lt.nres-1) then
8566         itl1=itortyp(itype(l+1))
8567       else
8568         itl1=ntortyp+1
8569       endif
8570 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8571 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8572 cd     & ' itl',itl,' itl1',itl1
8573 #ifdef MOMENT
8574       if (imat.eq.1) then
8575         s1=dip(3,jj,i)*dip(3,kk,k)
8576       else
8577         s1=dip(2,jj,j)*dip(2,kk,l)
8578       endif
8579 #endif
8580       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8581       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8582       if (j.eq.l+1) then
8583         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8584         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8585       else
8586         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8587         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8588       endif
8589       call transpose2(EUg(1,1,k),auxmat(1,1))
8590       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8591       vv(1)=pizda(1,1)-pizda(2,2)
8592       vv(2)=pizda(2,1)+pizda(1,2)
8593       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8594 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8595 #ifdef MOMENT
8596       eello6_graph4=-(s1+s2+s3+s4)
8597 #else
8598       eello6_graph4=-(s2+s3+s4)
8599 #endif
8600 C Derivatives in gamma(i-1)
8601       if (i.gt.1) then
8602 #ifdef MOMENT
8603         if (imat.eq.1) then
8604           s1=dipderg(2,jj,i)*dip(3,kk,k)
8605         else
8606           s1=dipderg(4,jj,j)*dip(2,kk,l)
8607         endif
8608 #endif
8609         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8610         if (j.eq.l+1) then
8611           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8612           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8613         else
8614           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8615           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8616         endif
8617         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8618         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8619 cd          write (2,*) 'turn6 derivatives'
8620 #ifdef MOMENT
8621           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8622 #else
8623           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8624 #endif
8625         else
8626 #ifdef MOMENT
8627           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8628 #else
8629           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8630 #endif
8631         endif
8632       endif
8633 C Derivatives in gamma(k-1)
8634 #ifdef MOMENT
8635       if (imat.eq.1) then
8636         s1=dip(3,jj,i)*dipderg(2,kk,k)
8637       else
8638         s1=dip(2,jj,j)*dipderg(4,kk,l)
8639       endif
8640 #endif
8641       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8642       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8643       if (j.eq.l+1) then
8644         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8645         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8646       else
8647         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8648         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8649       endif
8650       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8651       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8652       vv(1)=pizda(1,1)-pizda(2,2)
8653       vv(2)=pizda(2,1)+pizda(1,2)
8654       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8655       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8656 #ifdef MOMENT
8657         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8658 #else
8659         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8660 #endif
8661       else
8662 #ifdef MOMENT
8663         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8664 #else
8665         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8666 #endif
8667       endif
8668 C Derivatives in gamma(j-1) or gamma(l-1)
8669       if (l.eq.j+1 .and. l.gt.1) then
8670         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8671         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8672         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8673         vv(1)=pizda(1,1)-pizda(2,2)
8674         vv(2)=pizda(2,1)+pizda(1,2)
8675         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8676         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8677       else if (j.gt.1) then
8678         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8679         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8680         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8681         vv(1)=pizda(1,1)-pizda(2,2)
8682         vv(2)=pizda(2,1)+pizda(1,2)
8683         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8684         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8685           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8686         else
8687           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8688         endif
8689       endif
8690 C Cartesian derivatives.
8691       do iii=1,2
8692         do kkk=1,5
8693           do lll=1,3
8694 #ifdef MOMENT
8695             if (iii.eq.1) then
8696               if (imat.eq.1) then
8697                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8698               else
8699                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8700               endif
8701             else
8702               if (imat.eq.1) then
8703                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8704               else
8705                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8706               endif
8707             endif
8708 #endif
8709             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8710      &        auxvec(1))
8711             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8712             if (j.eq.l+1) then
8713               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8714      &          b1(1,j+1),auxvec(1))
8715               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8716             else
8717               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8718      &          b1(1,l+1),auxvec(1))
8719               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8720             endif
8721             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8722      &        pizda(1,1))
8723             vv(1)=pizda(1,1)-pizda(2,2)
8724             vv(2)=pizda(2,1)+pizda(1,2)
8725             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8726             if (swap) then
8727               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8728 #ifdef MOMENT
8729                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8730      &             -(s1+s2+s4)
8731 #else
8732                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8733      &             -(s2+s4)
8734 #endif
8735                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8736               else
8737 #ifdef MOMENT
8738                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8739 #else
8740                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8741 #endif
8742                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8743               endif
8744             else
8745 #ifdef MOMENT
8746               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8747 #else
8748               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8749 #endif
8750               if (l.eq.j+1) then
8751                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8752               else
8753                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8754               endif
8755             endif
8756           enddo
8757         enddo
8758       enddo
8759       return
8760       end
8761 c----------------------------------------------------------------------------
8762       double precision function eello_turn6(i,jj,kk)
8763       implicit real*8 (a-h,o-z)
8764       include 'DIMENSIONS'
8765       include 'COMMON.IOUNITS'
8766       include 'COMMON.CHAIN'
8767       include 'COMMON.DERIV'
8768       include 'COMMON.INTERACT'
8769       include 'COMMON.CONTACTS'
8770       include 'COMMON.TORSION'
8771       include 'COMMON.VAR'
8772       include 'COMMON.GEO'
8773       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8774      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8775      &  ggg1(3),ggg2(3)
8776       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8777      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8778 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8779 C           the respective energy moment and not to the cluster cumulant.
8780       s1=0.0d0
8781       s8=0.0d0
8782       s13=0.0d0
8783 c
8784       eello_turn6=0.0d0
8785       j=i+4
8786       k=i+1
8787       l=i+3
8788       iti=itortyp(itype(i))
8789       itk=itortyp(itype(k))
8790       itk1=itortyp(itype(k+1))
8791       itl=itortyp(itype(l))
8792       itj=itortyp(itype(j))
8793 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8794 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8795 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8796 cd        eello6=0.0d0
8797 cd        return
8798 cd      endif
8799 cd      write (iout,*)
8800 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8801 cd     &   ' and',k,l
8802 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8803       do iii=1,2
8804         do kkk=1,5
8805           do lll=1,3
8806             derx_turn(lll,kkk,iii)=0.0d0
8807           enddo
8808         enddo
8809       enddo
8810 cd      eij=1.0d0
8811 cd      ekl=1.0d0
8812 cd      ekont=1.0d0
8813       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8814 cd      eello6_5=0.0d0
8815 cd      write (2,*) 'eello6_5',eello6_5
8816 #ifdef MOMENT
8817       call transpose2(AEA(1,1,1),auxmat(1,1))
8818       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8819       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8820       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8821 #endif
8822       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8823       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8824       s2 = scalar2(b1(1,k),vtemp1(1))
8825 #ifdef MOMENT
8826       call transpose2(AEA(1,1,2),atemp(1,1))
8827       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8828       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8829       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8830 #endif
8831       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8832       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8833       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8834 #ifdef MOMENT
8835       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8836       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8837       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8838       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8839       ss13 = scalar2(b1(1,k),vtemp4(1))
8840       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8841 #endif
8842 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8843 c      s1=0.0d0
8844 c      s2=0.0d0
8845 c      s8=0.0d0
8846 c      s12=0.0d0
8847 c      s13=0.0d0
8848       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8849 C Derivatives in gamma(i+2)
8850       s1d =0.0d0
8851       s8d =0.0d0
8852 #ifdef MOMENT
8853       call transpose2(AEA(1,1,1),auxmatd(1,1))
8854       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8855       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8856       call transpose2(AEAderg(1,1,2),atempd(1,1))
8857       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8858       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8859 #endif
8860       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8861       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8862       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8863 c      s1d=0.0d0
8864 c      s2d=0.0d0
8865 c      s8d=0.0d0
8866 c      s12d=0.0d0
8867 c      s13d=0.0d0
8868       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8869 C Derivatives in gamma(i+3)
8870 #ifdef MOMENT
8871       call transpose2(AEA(1,1,1),auxmatd(1,1))
8872       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8873       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8874       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8875 #endif
8876       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8877       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8878       s2d = scalar2(b1(1,k),vtemp1d(1))
8879 #ifdef MOMENT
8880       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8881       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8882 #endif
8883       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8884 #ifdef MOMENT
8885       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8886       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8887       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8888 #endif
8889 c      s1d=0.0d0
8890 c      s2d=0.0d0
8891 c      s8d=0.0d0
8892 c      s12d=0.0d0
8893 c      s13d=0.0d0
8894 #ifdef MOMENT
8895       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8896      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8897 #else
8898       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8899      &               -0.5d0*ekont*(s2d+s12d)
8900 #endif
8901 C Derivatives in gamma(i+4)
8902       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8903       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8904       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8905 #ifdef MOMENT
8906       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8907       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8908       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8909 #endif
8910 c      s1d=0.0d0
8911 c      s2d=0.0d0
8912 c      s8d=0.0d0
8913 C      s12d=0.0d0
8914 c      s13d=0.0d0
8915 #ifdef MOMENT
8916       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8917 #else
8918       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8919 #endif
8920 C Derivatives in gamma(i+5)
8921 #ifdef MOMENT
8922       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8923       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8924       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8925 #endif
8926       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8927       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8928       s2d = scalar2(b1(1,k),vtemp1d(1))
8929 #ifdef MOMENT
8930       call transpose2(AEA(1,1,2),atempd(1,1))
8931       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8932       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8933 #endif
8934       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8935       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8936 #ifdef MOMENT
8937       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8938       ss13d = scalar2(b1(1,k),vtemp4d(1))
8939       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8940 #endif
8941 c      s1d=0.0d0
8942 c      s2d=0.0d0
8943 c      s8d=0.0d0
8944 c      s12d=0.0d0
8945 c      s13d=0.0d0
8946 #ifdef MOMENT
8947       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8948      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8949 #else
8950       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8951      &               -0.5d0*ekont*(s2d+s12d)
8952 #endif
8953 C Cartesian derivatives
8954       do iii=1,2
8955         do kkk=1,5
8956           do lll=1,3
8957 #ifdef MOMENT
8958             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8959             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8960             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8961 #endif
8962             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8963             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8964      &          vtemp1d(1))
8965             s2d = scalar2(b1(1,k),vtemp1d(1))
8966 #ifdef MOMENT
8967             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8968             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8969             s8d = -(atempd(1,1)+atempd(2,2))*
8970      &           scalar2(cc(1,1,itl),vtemp2(1))
8971 #endif
8972             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8973      &           auxmatd(1,1))
8974             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8975             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8976 c      s1d=0.0d0
8977 c      s2d=0.0d0
8978 c      s8d=0.0d0
8979 c      s12d=0.0d0
8980 c      s13d=0.0d0
8981 #ifdef MOMENT
8982             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8983      &        - 0.5d0*(s1d+s2d)
8984 #else
8985             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8986      &        - 0.5d0*s2d
8987 #endif
8988 #ifdef MOMENT
8989             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8990      &        - 0.5d0*(s8d+s12d)
8991 #else
8992             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8993      &        - 0.5d0*s12d
8994 #endif
8995           enddo
8996         enddo
8997       enddo
8998 #ifdef MOMENT
8999       do kkk=1,5
9000         do lll=1,3
9001           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9002      &      achuj_tempd(1,1))
9003           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9004           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9005           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9006           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9007           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9008      &      vtemp4d(1))
9009           ss13d = scalar2(b1(1,k),vtemp4d(1))
9010           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9011           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9012         enddo
9013       enddo
9014 #endif
9015 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9016 cd     &  16*eel_turn6_num
9017 cd      goto 1112
9018       if (j.lt.nres-1) then
9019         j1=j+1
9020         j2=j-1
9021       else
9022         j1=j-1
9023         j2=j-2
9024       endif
9025       if (l.lt.nres-1) then
9026         l1=l+1
9027         l2=l-1
9028       else
9029         l1=l-1
9030         l2=l-2
9031       endif
9032       do ll=1,3
9033 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9034 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9035 cgrad        ghalf=0.5d0*ggg1(ll)
9036 cd        ghalf=0.0d0
9037         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9038         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9039         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9040      &    +ekont*derx_turn(ll,2,1)
9041         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9042         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9043      &    +ekont*derx_turn(ll,4,1)
9044         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9045         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9046         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9047 cgrad        ghalf=0.5d0*ggg2(ll)
9048 cd        ghalf=0.0d0
9049         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9050      &    +ekont*derx_turn(ll,2,2)
9051         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9052         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9053      &    +ekont*derx_turn(ll,4,2)
9054         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9055         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9056         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9057       enddo
9058 cd      goto 1112
9059 cgrad      do m=i+1,j-1
9060 cgrad        do ll=1,3
9061 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9062 cgrad        enddo
9063 cgrad      enddo
9064 cgrad      do m=k+1,l-1
9065 cgrad        do ll=1,3
9066 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9067 cgrad        enddo
9068 cgrad      enddo
9069 cgrad1112  continue
9070 cgrad      do m=i+2,j2
9071 cgrad        do ll=1,3
9072 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9073 cgrad        enddo
9074 cgrad      enddo
9075 cgrad      do m=k+2,l2
9076 cgrad        do ll=1,3
9077 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9078 cgrad        enddo
9079 cgrad      enddo
9080 cd      do iii=1,nres-3
9081 cd        write (2,*) iii,g_corr6_loc(iii)
9082 cd      enddo
9083       eello_turn6=ekont*eel_turn6
9084 cd      write (2,*) 'ekont',ekont
9085 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9086       return
9087       end
9088
9089 C-----------------------------------------------------------------------------
9090       double precision function scalar(u,v)
9091 !DIR$ INLINEALWAYS scalar
9092 #ifndef OSF
9093 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9094 #endif
9095       implicit none
9096       double precision u(3),v(3)
9097 cd      double precision sc
9098 cd      integer i
9099 cd      sc=0.0d0
9100 cd      do i=1,3
9101 cd        sc=sc+u(i)*v(i)
9102 cd      enddo
9103 cd      scalar=sc
9104
9105       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9106       return
9107       end
9108 crc-------------------------------------------------
9109       SUBROUTINE MATVEC2(A1,V1,V2)
9110 !DIR$ INLINEALWAYS MATVEC2
9111 #ifndef OSF
9112 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9113 #endif
9114       implicit real*8 (a-h,o-z)
9115       include 'DIMENSIONS'
9116       DIMENSION A1(2,2),V1(2),V2(2)
9117 c      DO 1 I=1,2
9118 c        VI=0.0
9119 c        DO 3 K=1,2
9120 c    3     VI=VI+A1(I,K)*V1(K)
9121 c        Vaux(I)=VI
9122 c    1 CONTINUE
9123
9124       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9125       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9126
9127       v2(1)=vaux1
9128       v2(2)=vaux2
9129       END
9130 C---------------------------------------
9131       SUBROUTINE MATMAT2(A1,A2,A3)
9132 #ifndef OSF
9133 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9134 #endif
9135       implicit real*8 (a-h,o-z)
9136       include 'DIMENSIONS'
9137       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9138 c      DIMENSION AI3(2,2)
9139 c        DO  J=1,2
9140 c          A3IJ=0.0
9141 c          DO K=1,2
9142 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9143 c          enddo
9144 c          A3(I,J)=A3IJ
9145 c       enddo
9146 c      enddo
9147
9148       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9149       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9150       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9151       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9152
9153       A3(1,1)=AI3_11
9154       A3(2,1)=AI3_21
9155       A3(1,2)=AI3_12
9156       A3(2,2)=AI3_22
9157       END
9158
9159 c-------------------------------------------------------------------------
9160       double precision function scalar2(u,v)
9161 !DIR$ INLINEALWAYS scalar2
9162       implicit none
9163       double precision u(2),v(2)
9164       double precision sc
9165       integer i
9166       scalar2=u(1)*v(1)+u(2)*v(2)
9167       return
9168       end
9169
9170 C-----------------------------------------------------------------------------
9171
9172       subroutine transpose2(a,at)
9173 !DIR$ INLINEALWAYS transpose2
9174 #ifndef OSF
9175 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9176 #endif
9177       implicit none
9178       double precision a(2,2),at(2,2)
9179       at(1,1)=a(1,1)
9180       at(1,2)=a(2,1)
9181       at(2,1)=a(1,2)
9182       at(2,2)=a(2,2)
9183       return
9184       end
9185 c--------------------------------------------------------------------------
9186       subroutine transpose(n,a,at)
9187       implicit none
9188       integer n,i,j
9189       double precision a(n,n),at(n,n)
9190       do i=1,n
9191         do j=1,n
9192           at(j,i)=a(i,j)
9193         enddo
9194       enddo
9195       return
9196       end
9197 C---------------------------------------------------------------------------
9198       subroutine prodmat3(a1,a2,kk,transp,prod)
9199 !DIR$ INLINEALWAYS prodmat3
9200 #ifndef OSF
9201 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9202 #endif
9203       implicit none
9204       integer i,j
9205       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9206       logical transp
9207 crc      double precision auxmat(2,2),prod_(2,2)
9208
9209       if (transp) then
9210 crc        call transpose2(kk(1,1),auxmat(1,1))
9211 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9212 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9213
9214            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9215      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9216            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9217      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9218            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9219      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9220            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9221      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9222
9223       else
9224 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9225 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9226
9227            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9228      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9229            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9230      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9231            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9232      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9233            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9234      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9235
9236       endif
9237 c      call transpose2(a2(1,1),a2t(1,1))
9238
9239 crc      print *,transp
9240 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9241 crc      print *,((prod(i,j),i=1,2),j=1,2)
9242
9243       return
9244       end
9245