source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       integer xshift,yshift,zshift
1417       evdw=0.0D0
1418 ccccc      energy_dec=.false.
1419 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1420       evdw=0.0D0
1421       lprn=.false.
1422 c     if (icall.eq.0) lprn=.false.
1423       ind=0
1424 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1425 C we have the original box)
1426       do xshift=-1,1
1427       do yshift=-1,1
1428       do zshift=-1,1
1429       do i=iatsc_s,iatsc_e
1430         itypi=iabs(itype(i))
1431         if (itypi.eq.ntyp1) cycle
1432         itypi1=iabs(itype(i+1))
1433         xi=c(1,nres+i)
1434         yi=c(2,nres+i)
1435         zi=c(3,nres+i)
1436 C Return atom into box, boxxsize is size of box in x dimension
1437   134   continue
1438         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1439         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1440 C Condition for being inside the proper box
1441         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1442      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1443         go to 134
1444         endif
1445   135   continue
1446         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1447         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1448 C Condition for being inside the proper box
1449         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1450      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1451         go to 135
1452         endif
1453   136   continue
1454         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxxsize
1455         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxxsize
1456 C Condition for being inside the proper box
1457         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1458      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1459         go to 136
1460         endif
1461
1462         dxi=dc_norm(1,nres+i)
1463         dyi=dc_norm(2,nres+i)
1464         dzi=dc_norm(3,nres+i)
1465 c        dsci_inv=dsc_inv(itypi)
1466         dsci_inv=vbld_inv(i+nres)
1467 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1468 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1469 C
1470 C Calculate SC interaction energy.
1471 C
1472         do iint=1,nint_gr(i)
1473           do j=istart(i,iint),iend(i,iint)
1474             ind=ind+1
1475             itypj=iabs(itype(j))
1476             if (itypj.eq.ntyp1) cycle
1477 c            dscj_inv=dsc_inv(itypj)
1478             dscj_inv=vbld_inv(j+nres)
1479 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1480 c     &       1.0d0/vbld(j+nres)
1481 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1482             sig0ij=sigma(itypi,itypj)
1483             chi1=chi(itypi,itypj)
1484             chi2=chi(itypj,itypi)
1485             chi12=chi1*chi2
1486             chip1=chip(itypi)
1487             chip2=chip(itypj)
1488             chip12=chip1*chip2
1489             alf1=alp(itypi)
1490             alf2=alp(itypj)
1491             alf12=0.5D0*(alf1+alf2)
1492 C For diagnostics only!!!
1493 c           chi1=0.0D0
1494 c           chi2=0.0D0
1495 c           chi12=0.0D0
1496 c           chip1=0.0D0
1497 c           chip2=0.0D0
1498 c           chip12=0.0D0
1499 c           alf1=0.0D0
1500 c           alf2=0.0D0
1501 c           alf12=0.0D0
1502             xj=c(1,nres+j)
1503             yj=c(2,nres+j)
1504             zj=c(3,nres+j)
1505 C Return atom J into box the original box
1506   137   continue
1507         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1508         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1509 C Condition for being inside the proper box
1510         if ((xj.gt.((0.5d0)*boxxsize)).or.
1511      &       (xj.lt.((-0.5d0)*boxxsize))) then
1512         go to 137
1513         endif
1514   138   continue
1515         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1516         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1517 C Condition for being inside the proper box
1518         if ((yj.gt.((0.5d0)*boxysize)).or.
1519      &       (yj.lt.((-0.5d0)*boxysize))) then
1520         go to 138
1521         endif
1522   139   continue
1523         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxxsize
1524         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxxsize
1525 C Condition for being inside the proper box
1526         if ((zj.gt.((0.5d0)*boxzsize)).or.
1527      &       (zj.lt.((-0.5d0)*boxzsize))) then
1528         go to 139
1529         endif
1530
1531             dxj=dc_norm(1,nres+j)
1532             dyj=dc_norm(2,nres+j)
1533             dzj=dc_norm(3,nres+j)
1534             xj=xj-xi
1535             yj=yj-yi
1536             zj=zj-zi
1537 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1538 c            write (iout,*) "j",j," dc_norm",
1539 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1540             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1541             rij=dsqrt(rrij)
1542 C Calculate angle-dependent terms of energy and contributions to their
1543 C derivatives.
1544             call sc_angular
1545             sigsq=1.0D0/sigsq
1546             sig=sig0ij*dsqrt(sigsq)
1547             rij_shift=1.0D0/rij-sig+sig0ij
1548 c for diagnostics; uncomment
1549 c            rij_shift=1.2*sig0ij
1550 C I hate to put IF's in the loops, but here don't have another choice!!!!
1551             if (rij_shift.le.0.0D0) then
1552               evdw=1.0D20
1553 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1554 cd     &        restyp(itypi),i,restyp(itypj),j,
1555 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1556               return
1557             endif
1558             sigder=-sig*sigsq
1559 c---------------------------------------------------------------
1560             rij_shift=1.0D0/rij_shift
1561             fac=rij_shift**expon
1562             e1=fac*fac*aa(itypi,itypj)
1563             e2=fac*bb(itypi,itypj)
1564             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1565             eps2der=evdwij*eps3rt
1566             eps3der=evdwij*eps2rt
1567 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1568 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1569             evdwij=evdwij*eps2rt*eps3rt
1570             evdw=evdw+evdwij
1571             if (lprn) then
1572             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1573             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1574             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1575      &        restyp(itypi),i,restyp(itypj),j,
1576      &        epsi,sigm,chi1,chi2,chip1,chip2,
1577      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1578      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1579      &        evdwij
1580             endif
1581
1582             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1583      &                        'evdw',i,j,evdwij
1584
1585 C Calculate gradient components.
1586             e1=e1*eps1*eps2rt**2*eps3rt**2
1587             fac=-expon*(e1+evdwij)*rij_shift
1588             sigder=fac*sigder
1589             fac=rij*fac
1590 c            fac=0.0d0
1591 C Calculate the radial part of the gradient
1592             gg(1)=xj*fac
1593             gg(2)=yj*fac
1594             gg(3)=zj*fac
1595 C Calculate angular part of the gradient.
1596             call sc_grad
1597           enddo      ! j
1598         enddo        ! iint
1599       enddo          ! i
1600       enddo          ! zshift
1601       enddo          ! yshift
1602       enddo          ! xshift
1603 c      write (iout,*) "Number of loop steps in EGB:",ind
1604 cccc      energy_dec=.false.
1605       return
1606       end
1607 C-----------------------------------------------------------------------------
1608       subroutine egbv(evdw)
1609 C
1610 C This subroutine calculates the interaction energy of nonbonded side chains
1611 C assuming the Gay-Berne-Vorobjev potential of interaction.
1612 C
1613       implicit real*8 (a-h,o-z)
1614       include 'DIMENSIONS'
1615       include 'COMMON.GEO'
1616       include 'COMMON.VAR'
1617       include 'COMMON.LOCAL'
1618       include 'COMMON.CHAIN'
1619       include 'COMMON.DERIV'
1620       include 'COMMON.NAMES'
1621       include 'COMMON.INTERACT'
1622       include 'COMMON.IOUNITS'
1623       include 'COMMON.CALC'
1624       common /srutu/ icall
1625       logical lprn
1626       evdw=0.0D0
1627 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1628       evdw=0.0D0
1629       lprn=.false.
1630 c     if (icall.eq.0) lprn=.true.
1631       ind=0
1632       do i=iatsc_s,iatsc_e
1633         itypi=iabs(itype(i))
1634         if (itypi.eq.ntyp1) cycle
1635         itypi1=iabs(itype(i+1))
1636         xi=c(1,nres+i)
1637         yi=c(2,nres+i)
1638         zi=c(3,nres+i)
1639         dxi=dc_norm(1,nres+i)
1640         dyi=dc_norm(2,nres+i)
1641         dzi=dc_norm(3,nres+i)
1642 c        dsci_inv=dsc_inv(itypi)
1643         dsci_inv=vbld_inv(i+nres)
1644 C
1645 C Calculate SC interaction energy.
1646 C
1647         do iint=1,nint_gr(i)
1648           do j=istart(i,iint),iend(i,iint)
1649             ind=ind+1
1650             itypj=iabs(itype(j))
1651             if (itypj.eq.ntyp1) cycle
1652 c            dscj_inv=dsc_inv(itypj)
1653             dscj_inv=vbld_inv(j+nres)
1654             sig0ij=sigma(itypi,itypj)
1655             r0ij=r0(itypi,itypj)
1656             chi1=chi(itypi,itypj)
1657             chi2=chi(itypj,itypi)
1658             chi12=chi1*chi2
1659             chip1=chip(itypi)
1660             chip2=chip(itypj)
1661             chip12=chip1*chip2
1662             alf1=alp(itypi)
1663             alf2=alp(itypj)
1664             alf12=0.5D0*(alf1+alf2)
1665 C For diagnostics only!!!
1666 c           chi1=0.0D0
1667 c           chi2=0.0D0
1668 c           chi12=0.0D0
1669 c           chip1=0.0D0
1670 c           chip2=0.0D0
1671 c           chip12=0.0D0
1672 c           alf1=0.0D0
1673 c           alf2=0.0D0
1674 c           alf12=0.0D0
1675             xj=c(1,nres+j)-xi
1676             yj=c(2,nres+j)-yi
1677             zj=c(3,nres+j)-zi
1678             dxj=dc_norm(1,nres+j)
1679             dyj=dc_norm(2,nres+j)
1680             dzj=dc_norm(3,nres+j)
1681             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1682             rij=dsqrt(rrij)
1683 C Calculate angle-dependent terms of energy and contributions to their
1684 C derivatives.
1685             call sc_angular
1686             sigsq=1.0D0/sigsq
1687             sig=sig0ij*dsqrt(sigsq)
1688             rij_shift=1.0D0/rij-sig+r0ij
1689 C I hate to put IF's in the loops, but here don't have another choice!!!!
1690             if (rij_shift.le.0.0D0) then
1691               evdw=1.0D20
1692               return
1693             endif
1694             sigder=-sig*sigsq
1695 c---------------------------------------------------------------
1696             rij_shift=1.0D0/rij_shift
1697             fac=rij_shift**expon
1698             e1=fac*fac*aa(itypi,itypj)
1699             e2=fac*bb(itypi,itypj)
1700             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1701             eps2der=evdwij*eps3rt
1702             eps3der=evdwij*eps2rt
1703             fac_augm=rrij**expon
1704             e_augm=augm(itypi,itypj)*fac_augm
1705             evdwij=evdwij*eps2rt*eps3rt
1706             evdw=evdw+evdwij+e_augm
1707             if (lprn) then
1708             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1709             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1710             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1711      &        restyp(itypi),i,restyp(itypj),j,
1712      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1713      &        chi1,chi2,chip1,chip2,
1714      &        eps1,eps2rt**2,eps3rt**2,
1715      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1716      &        evdwij+e_augm
1717             endif
1718 C Calculate gradient components.
1719             e1=e1*eps1*eps2rt**2*eps3rt**2
1720             fac=-expon*(e1+evdwij)*rij_shift
1721             sigder=fac*sigder
1722             fac=rij*fac-2*expon*rrij*e_augm
1723 C Calculate the radial part of the gradient
1724             gg(1)=xj*fac
1725             gg(2)=yj*fac
1726             gg(3)=zj*fac
1727 C Calculate angular part of the gradient.
1728             call sc_grad
1729           enddo      ! j
1730         enddo        ! iint
1731       enddo          ! i
1732       end
1733 C-----------------------------------------------------------------------------
1734       subroutine sc_angular
1735 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1736 C om12. Called by ebp, egb, and egbv.
1737       implicit none
1738       include 'COMMON.CALC'
1739       include 'COMMON.IOUNITS'
1740       erij(1)=xj*rij
1741       erij(2)=yj*rij
1742       erij(3)=zj*rij
1743       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1744       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1745       om12=dxi*dxj+dyi*dyj+dzi*dzj
1746       chiom12=chi12*om12
1747 C Calculate eps1(om12) and its derivative in om12
1748       faceps1=1.0D0-om12*chiom12
1749       faceps1_inv=1.0D0/faceps1
1750       eps1=dsqrt(faceps1_inv)
1751 C Following variable is eps1*deps1/dom12
1752       eps1_om12=faceps1_inv*chiom12
1753 c diagnostics only
1754 c      faceps1_inv=om12
1755 c      eps1=om12
1756 c      eps1_om12=1.0d0
1757 c      write (iout,*) "om12",om12," eps1",eps1
1758 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1759 C and om12.
1760       om1om2=om1*om2
1761       chiom1=chi1*om1
1762       chiom2=chi2*om2
1763       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1764       sigsq=1.0D0-facsig*faceps1_inv
1765       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1766       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1767       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1768 c diagnostics only
1769 c      sigsq=1.0d0
1770 c      sigsq_om1=0.0d0
1771 c      sigsq_om2=0.0d0
1772 c      sigsq_om12=0.0d0
1773 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1774 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1775 c     &    " eps1",eps1
1776 C Calculate eps2 and its derivatives in om1, om2, and om12.
1777       chipom1=chip1*om1
1778       chipom2=chip2*om2
1779       chipom12=chip12*om12
1780       facp=1.0D0-om12*chipom12
1781       facp_inv=1.0D0/facp
1782       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1783 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1784 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1785 C Following variable is the square root of eps2
1786       eps2rt=1.0D0-facp1*facp_inv
1787 C Following three variables are the derivatives of the square root of eps
1788 C in om1, om2, and om12.
1789       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1790       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1791       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1792 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1793       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1794 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1795 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1796 c     &  " eps2rt_om12",eps2rt_om12
1797 C Calculate whole angle-dependent part of epsilon and contributions
1798 C to its derivatives
1799       return
1800       end
1801 C----------------------------------------------------------------------------
1802       subroutine sc_grad
1803       implicit real*8 (a-h,o-z)
1804       include 'DIMENSIONS'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.CALC'
1808       include 'COMMON.IOUNITS'
1809       double precision dcosom1(3),dcosom2(3)
1810       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1811       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1812       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1813      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1814 c diagnostics only
1815 c      eom1=0.0d0
1816 c      eom2=0.0d0
1817 c      eom12=evdwij*eps1_om12
1818 c end diagnostics
1819 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1820 c     &  " sigder",sigder
1821 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1822 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1823       do k=1,3
1824         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1825         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1826       enddo
1827       do k=1,3
1828         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1829       enddo
1830 c      write (iout,*) "gg",(gg(k),k=1,3)
1831       do k=1,3
1832         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1833      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1834      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1835         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1836      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1837      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1838 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1839 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1840 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1841 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1842       enddo
1843 C
1844 C Calculate the components of the gradient in DC and X
1845 C
1846 cgrad      do k=i,j-1
1847 cgrad        do l=1,3
1848 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1849 cgrad        enddo
1850 cgrad      enddo
1851       do l=1,3
1852         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1853         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1854       enddo
1855       return
1856       end
1857 C-----------------------------------------------------------------------
1858       subroutine e_softsphere(evdw)
1859 C
1860 C This subroutine calculates the interaction energy of nonbonded side chains
1861 C assuming the LJ potential of interaction.
1862 C
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       parameter (accur=1.0d-10)
1866       include 'COMMON.GEO'
1867       include 'COMMON.VAR'
1868       include 'COMMON.LOCAL'
1869       include 'COMMON.CHAIN'
1870       include 'COMMON.DERIV'
1871       include 'COMMON.INTERACT'
1872       include 'COMMON.TORSION'
1873       include 'COMMON.SBRIDGE'
1874       include 'COMMON.NAMES'
1875       include 'COMMON.IOUNITS'
1876       include 'COMMON.CONTACTS'
1877       dimension gg(3)
1878 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1879       evdw=0.0D0
1880       do i=iatsc_s,iatsc_e
1881         itypi=iabs(itype(i))
1882         if (itypi.eq.ntyp1) cycle
1883         itypi1=iabs(itype(i+1))
1884         xi=c(1,nres+i)
1885         yi=c(2,nres+i)
1886         zi=c(3,nres+i)
1887 C
1888 C Calculate SC interaction energy.
1889 C
1890         do iint=1,nint_gr(i)
1891 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1892 cd   &                  'iend=',iend(i,iint)
1893           do j=istart(i,iint),iend(i,iint)
1894             itypj=iabs(itype(j))
1895             if (itypj.eq.ntyp1) cycle
1896             xj=c(1,nres+j)-xi
1897             yj=c(2,nres+j)-yi
1898             zj=c(3,nres+j)-zi
1899             rij=xj*xj+yj*yj+zj*zj
1900 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1901             r0ij=r0(itypi,itypj)
1902             r0ijsq=r0ij*r0ij
1903 c            print *,i,j,r0ij,dsqrt(rij)
1904             if (rij.lt.r0ijsq) then
1905               evdwij=0.25d0*(rij-r0ijsq)**2
1906               fac=rij-r0ijsq
1907             else
1908               evdwij=0.0d0
1909               fac=0.0d0
1910             endif
1911             evdw=evdw+evdwij
1912 C
1913 C Calculate the components of the gradient in DC and X
1914 C
1915             gg(1)=xj*fac
1916             gg(2)=yj*fac
1917             gg(3)=zj*fac
1918             do k=1,3
1919               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1920               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1921               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1922               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1923             enddo
1924 cgrad            do k=i,j-1
1925 cgrad              do l=1,3
1926 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1927 cgrad              enddo
1928 cgrad            enddo
1929           enddo ! j
1930         enddo ! iint
1931       enddo ! i
1932       return
1933       end
1934 C--------------------------------------------------------------------------
1935       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1936      &              eello_turn4)
1937 C
1938 C Soft-sphere potential of p-p interaction
1939 C
1940       implicit real*8 (a-h,o-z)
1941       include 'DIMENSIONS'
1942       include 'COMMON.CONTROL'
1943       include 'COMMON.IOUNITS'
1944       include 'COMMON.GEO'
1945       include 'COMMON.VAR'
1946       include 'COMMON.LOCAL'
1947       include 'COMMON.CHAIN'
1948       include 'COMMON.DERIV'
1949       include 'COMMON.INTERACT'
1950       include 'COMMON.CONTACTS'
1951       include 'COMMON.TORSION'
1952       include 'COMMON.VECTORS'
1953       include 'COMMON.FFIELD'
1954       dimension ggg(3)
1955 cd      write(iout,*) 'In EELEC_soft_sphere'
1956       ees=0.0D0
1957       evdw1=0.0D0
1958       eel_loc=0.0d0
1959       eello_turn3=0.0d0
1960       eello_turn4=0.0d0
1961       ind=0
1962       do i=iatel_s,iatel_e
1963         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1964         dxi=dc(1,i)
1965         dyi=dc(2,i)
1966         dzi=dc(3,i)
1967         xmedi=c(1,i)+0.5d0*dxi
1968         ymedi=c(2,i)+0.5d0*dyi
1969         zmedi=c(3,i)+0.5d0*dzi
1970         num_conti=0
1971 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1972         do j=ielstart(i),ielend(i)
1973           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1974           ind=ind+1
1975           iteli=itel(i)
1976           itelj=itel(j)
1977           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1978           r0ij=rpp(iteli,itelj)
1979           r0ijsq=r0ij*r0ij
1980           dxj=dc(1,j)
1981           dyj=dc(2,j)
1982           dzj=dc(3,j)
1983           xj=c(1,j)+0.5D0*dxj-xmedi
1984           yj=c(2,j)+0.5D0*dyj-ymedi
1985           zj=c(3,j)+0.5D0*dzj-zmedi
1986           rij=xj*xj+yj*yj+zj*zj
1987           if (rij.lt.r0ijsq) then
1988             evdw1ij=0.25d0*(rij-r0ijsq)**2
1989             fac=rij-r0ijsq
1990           else
1991             evdw1ij=0.0d0
1992             fac=0.0d0
1993           endif
1994           evdw1=evdw1+evdw1ij
1995 C
1996 C Calculate contributions to the Cartesian gradient.
1997 C
1998           ggg(1)=fac*xj
1999           ggg(2)=fac*yj
2000           ggg(3)=fac*zj
2001           do k=1,3
2002             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2003             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2004           enddo
2005 *
2006 * Loop over residues i+1 thru j-1.
2007 *
2008 cgrad          do k=i+1,j-1
2009 cgrad            do l=1,3
2010 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2011 cgrad            enddo
2012 cgrad          enddo
2013         enddo ! j
2014       enddo   ! i
2015 cgrad      do i=nnt,nct-1
2016 cgrad        do k=1,3
2017 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2018 cgrad        enddo
2019 cgrad        do j=i+1,nct-1
2020 cgrad          do k=1,3
2021 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2022 cgrad          enddo
2023 cgrad        enddo
2024 cgrad      enddo
2025       return
2026       end
2027 c------------------------------------------------------------------------------
2028       subroutine vec_and_deriv
2029       implicit real*8 (a-h,o-z)
2030       include 'DIMENSIONS'
2031 #ifdef MPI
2032       include 'mpif.h'
2033 #endif
2034       include 'COMMON.IOUNITS'
2035       include 'COMMON.GEO'
2036       include 'COMMON.VAR'
2037       include 'COMMON.LOCAL'
2038       include 'COMMON.CHAIN'
2039       include 'COMMON.VECTORS'
2040       include 'COMMON.SETUP'
2041       include 'COMMON.TIME1'
2042       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2043 C Compute the local reference systems. For reference system (i), the
2044 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2045 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2046 #ifdef PARVEC
2047       do i=ivec_start,ivec_end
2048 #else
2049       do i=1,nres-1
2050 #endif
2051           if (i.eq.nres-1) then
2052 C Case of the last full residue
2053 C Compute the Z-axis
2054             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2055             costh=dcos(pi-theta(nres))
2056             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2057             do k=1,3
2058               uz(k,i)=fac*uz(k,i)
2059             enddo
2060 C Compute the derivatives of uz
2061             uzder(1,1,1)= 0.0d0
2062             uzder(2,1,1)=-dc_norm(3,i-1)
2063             uzder(3,1,1)= dc_norm(2,i-1)
2064             uzder(1,2,1)= dc_norm(3,i-1)
2065             uzder(2,2,1)= 0.0d0
2066             uzder(3,2,1)=-dc_norm(1,i-1)
2067             uzder(1,3,1)=-dc_norm(2,i-1)
2068             uzder(2,3,1)= dc_norm(1,i-1)
2069             uzder(3,3,1)= 0.0d0
2070             uzder(1,1,2)= 0.0d0
2071             uzder(2,1,2)= dc_norm(3,i)
2072             uzder(3,1,2)=-dc_norm(2,i)
2073             uzder(1,2,2)=-dc_norm(3,i)
2074             uzder(2,2,2)= 0.0d0
2075             uzder(3,2,2)= dc_norm(1,i)
2076             uzder(1,3,2)= dc_norm(2,i)
2077             uzder(2,3,2)=-dc_norm(1,i)
2078             uzder(3,3,2)= 0.0d0
2079 C Compute the Y-axis
2080             facy=fac
2081             do k=1,3
2082               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2083             enddo
2084 C Compute the derivatives of uy
2085             do j=1,3
2086               do k=1,3
2087                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2088      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2089                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2090               enddo
2091               uyder(j,j,1)=uyder(j,j,1)-costh
2092               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2093             enddo
2094             do j=1,2
2095               do k=1,3
2096                 do l=1,3
2097                   uygrad(l,k,j,i)=uyder(l,k,j)
2098                   uzgrad(l,k,j,i)=uzder(l,k,j)
2099                 enddo
2100               enddo
2101             enddo
2102             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2103             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2104             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2105             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2106           else
2107 C Other residues
2108 C Compute the Z-axis
2109             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2110             costh=dcos(pi-theta(i+2))
2111             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2112             do k=1,3
2113               uz(k,i)=fac*uz(k,i)
2114             enddo
2115 C Compute the derivatives of uz
2116             uzder(1,1,1)= 0.0d0
2117             uzder(2,1,1)=-dc_norm(3,i+1)
2118             uzder(3,1,1)= dc_norm(2,i+1)
2119             uzder(1,2,1)= dc_norm(3,i+1)
2120             uzder(2,2,1)= 0.0d0
2121             uzder(3,2,1)=-dc_norm(1,i+1)
2122             uzder(1,3,1)=-dc_norm(2,i+1)
2123             uzder(2,3,1)= dc_norm(1,i+1)
2124             uzder(3,3,1)= 0.0d0
2125             uzder(1,1,2)= 0.0d0
2126             uzder(2,1,2)= dc_norm(3,i)
2127             uzder(3,1,2)=-dc_norm(2,i)
2128             uzder(1,2,2)=-dc_norm(3,i)
2129             uzder(2,2,2)= 0.0d0
2130             uzder(3,2,2)= dc_norm(1,i)
2131             uzder(1,3,2)= dc_norm(2,i)
2132             uzder(2,3,2)=-dc_norm(1,i)
2133             uzder(3,3,2)= 0.0d0
2134 C Compute the Y-axis
2135             facy=fac
2136             do k=1,3
2137               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2138             enddo
2139 C Compute the derivatives of uy
2140             do j=1,3
2141               do k=1,3
2142                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2143      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2144                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2145               enddo
2146               uyder(j,j,1)=uyder(j,j,1)-costh
2147               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2148             enddo
2149             do j=1,2
2150               do k=1,3
2151                 do l=1,3
2152                   uygrad(l,k,j,i)=uyder(l,k,j)
2153                   uzgrad(l,k,j,i)=uzder(l,k,j)
2154                 enddo
2155               enddo
2156             enddo
2157             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2158             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2159             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2160             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2161           endif
2162       enddo
2163       do i=1,nres-1
2164         vbld_inv_temp(1)=vbld_inv(i+1)
2165         if (i.lt.nres-1) then
2166           vbld_inv_temp(2)=vbld_inv(i+2)
2167           else
2168           vbld_inv_temp(2)=vbld_inv(i)
2169           endif
2170         do j=1,2
2171           do k=1,3
2172             do l=1,3
2173               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2174               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2175             enddo
2176           enddo
2177         enddo
2178       enddo
2179 #if defined(PARVEC) && defined(MPI)
2180       if (nfgtasks1.gt.1) then
2181         time00=MPI_Wtime()
2182 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2183 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2184 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2185         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2186      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2187      &   FG_COMM1,IERR)
2188         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2189      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2190      &   FG_COMM1,IERR)
2191         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2192      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2193      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2194         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2195      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2196      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2197         time_gather=time_gather+MPI_Wtime()-time00
2198       endif
2199 c      if (fg_rank.eq.0) then
2200 c        write (iout,*) "Arrays UY and UZ"
2201 c        do i=1,nres-1
2202 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2203 c     &     (uz(k,i),k=1,3)
2204 c        enddo
2205 c      endif
2206 #endif
2207       return
2208       end
2209 C-----------------------------------------------------------------------------
2210       subroutine check_vecgrad
2211       implicit real*8 (a-h,o-z)
2212       include 'DIMENSIONS'
2213       include 'COMMON.IOUNITS'
2214       include 'COMMON.GEO'
2215       include 'COMMON.VAR'
2216       include 'COMMON.LOCAL'
2217       include 'COMMON.CHAIN'
2218       include 'COMMON.VECTORS'
2219       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2220       dimension uyt(3,maxres),uzt(3,maxres)
2221       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2222       double precision delta /1.0d-7/
2223       call vec_and_deriv
2224 cd      do i=1,nres
2225 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2226 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2227 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2228 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2229 cd     &     (dc_norm(if90,i),if90=1,3)
2230 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2231 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2232 cd          write(iout,'(a)')
2233 cd      enddo
2234       do i=1,nres
2235         do j=1,2
2236           do k=1,3
2237             do l=1,3
2238               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2239               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2240             enddo
2241           enddo
2242         enddo
2243       enddo
2244       call vec_and_deriv
2245       do i=1,nres
2246         do j=1,3
2247           uyt(j,i)=uy(j,i)
2248           uzt(j,i)=uz(j,i)
2249         enddo
2250       enddo
2251       do i=1,nres
2252 cd        write (iout,*) 'i=',i
2253         do k=1,3
2254           erij(k)=dc_norm(k,i)
2255         enddo
2256         do j=1,3
2257           do k=1,3
2258             dc_norm(k,i)=erij(k)
2259           enddo
2260           dc_norm(j,i)=dc_norm(j,i)+delta
2261 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2262 c          do k=1,3
2263 c            dc_norm(k,i)=dc_norm(k,i)/fac
2264 c          enddo
2265 c          write (iout,*) (dc_norm(k,i),k=1,3)
2266 c          write (iout,*) (erij(k),k=1,3)
2267           call vec_and_deriv
2268           do k=1,3
2269             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2270             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2271             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2272             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2273           enddo
2274 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2275 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2276 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2277         enddo
2278         do k=1,3
2279           dc_norm(k,i)=erij(k)
2280         enddo
2281 cd        do k=1,3
2282 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2283 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2284 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2285 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2286 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2287 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2288 cd          write (iout,'(a)')
2289 cd        enddo
2290       enddo
2291       return
2292       end
2293 C--------------------------------------------------------------------------
2294       subroutine set_matrices
2295       implicit real*8 (a-h,o-z)
2296       include 'DIMENSIONS'
2297 #ifdef MPI
2298       include "mpif.h"
2299       include "COMMON.SETUP"
2300       integer IERR
2301       integer status(MPI_STATUS_SIZE)
2302 #endif
2303       include 'COMMON.IOUNITS'
2304       include 'COMMON.GEO'
2305       include 'COMMON.VAR'
2306       include 'COMMON.LOCAL'
2307       include 'COMMON.CHAIN'
2308       include 'COMMON.DERIV'
2309       include 'COMMON.INTERACT'
2310       include 'COMMON.CONTACTS'
2311       include 'COMMON.TORSION'
2312       include 'COMMON.VECTORS'
2313       include 'COMMON.FFIELD'
2314       double precision auxvec(2),auxmat(2,2)
2315 C
2316 C Compute the virtual-bond-torsional-angle dependent quantities needed
2317 C to calculate the el-loc multibody terms of various order.
2318 C
2319 #ifdef PARMAT
2320       do i=ivec_start+2,ivec_end+2
2321 #else
2322       do i=3,nres+1
2323 #endif
2324         if (i .lt. nres+1) then
2325           sin1=dsin(phi(i))
2326           cos1=dcos(phi(i))
2327           sintab(i-2)=sin1
2328           costab(i-2)=cos1
2329           obrot(1,i-2)=cos1
2330           obrot(2,i-2)=sin1
2331           sin2=dsin(2*phi(i))
2332           cos2=dcos(2*phi(i))
2333           sintab2(i-2)=sin2
2334           costab2(i-2)=cos2
2335           obrot2(1,i-2)=cos2
2336           obrot2(2,i-2)=sin2
2337           Ug(1,1,i-2)=-cos1
2338           Ug(1,2,i-2)=-sin1
2339           Ug(2,1,i-2)=-sin1
2340           Ug(2,2,i-2)= cos1
2341           Ug2(1,1,i-2)=-cos2
2342           Ug2(1,2,i-2)=-sin2
2343           Ug2(2,1,i-2)=-sin2
2344           Ug2(2,2,i-2)= cos2
2345         else
2346           costab(i-2)=1.0d0
2347           sintab(i-2)=0.0d0
2348           obrot(1,i-2)=1.0d0
2349           obrot(2,i-2)=0.0d0
2350           obrot2(1,i-2)=0.0d0
2351           obrot2(2,i-2)=0.0d0
2352           Ug(1,1,i-2)=1.0d0
2353           Ug(1,2,i-2)=0.0d0
2354           Ug(2,1,i-2)=0.0d0
2355           Ug(2,2,i-2)=1.0d0
2356           Ug2(1,1,i-2)=0.0d0
2357           Ug2(1,2,i-2)=0.0d0
2358           Ug2(2,1,i-2)=0.0d0
2359           Ug2(2,2,i-2)=0.0d0
2360         endif
2361         if (i .gt. 3 .and. i .lt. nres+1) then
2362           obrot_der(1,i-2)=-sin1
2363           obrot_der(2,i-2)= cos1
2364           Ugder(1,1,i-2)= sin1
2365           Ugder(1,2,i-2)=-cos1
2366           Ugder(2,1,i-2)=-cos1
2367           Ugder(2,2,i-2)=-sin1
2368           dwacos2=cos2+cos2
2369           dwasin2=sin2+sin2
2370           obrot2_der(1,i-2)=-dwasin2
2371           obrot2_der(2,i-2)= dwacos2
2372           Ug2der(1,1,i-2)= dwasin2
2373           Ug2der(1,2,i-2)=-dwacos2
2374           Ug2der(2,1,i-2)=-dwacos2
2375           Ug2der(2,2,i-2)=-dwasin2
2376         else
2377           obrot_der(1,i-2)=0.0d0
2378           obrot_der(2,i-2)=0.0d0
2379           Ugder(1,1,i-2)=0.0d0
2380           Ugder(1,2,i-2)=0.0d0
2381           Ugder(2,1,i-2)=0.0d0
2382           Ugder(2,2,i-2)=0.0d0
2383           obrot2_der(1,i-2)=0.0d0
2384           obrot2_der(2,i-2)=0.0d0
2385           Ug2der(1,1,i-2)=0.0d0
2386           Ug2der(1,2,i-2)=0.0d0
2387           Ug2der(2,1,i-2)=0.0d0
2388           Ug2der(2,2,i-2)=0.0d0
2389         endif
2390 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2391         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2392           iti = itortyp(itype(i-2))
2393         else
2394           iti=ntortyp+1
2395         endif
2396 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2397         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2398           iti1 = itortyp(itype(i-1))
2399         else
2400           iti1=ntortyp+1
2401         endif
2402 cd        write (iout,*) '*******i',i,' iti1',iti
2403 cd        write (iout,*) 'b1',b1(:,iti)
2404 cd        write (iout,*) 'b2',b2(:,iti)
2405 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2406 c        if (i .gt. iatel_s+2) then
2407         if (i .gt. nnt+2) then
2408           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2409           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2410           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2411      &    then
2412           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2413           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2414           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2415           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2416           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2417           endif
2418         else
2419           do k=1,2
2420             Ub2(k,i-2)=0.0d0
2421             Ctobr(k,i-2)=0.0d0
2422             Dtobr2(k,i-2)=0.0d0
2423             do l=1,2
2424               EUg(l,k,i-2)=0.0d0
2425               CUg(l,k,i-2)=0.0d0
2426               DUg(l,k,i-2)=0.0d0
2427               DtUg2(l,k,i-2)=0.0d0
2428             enddo
2429           enddo
2430         endif
2431         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2432         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2433         do k=1,2
2434           muder(k,i-2)=Ub2der(k,i-2)
2435         enddo
2436 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2437         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2438           if (itype(i-1).le.ntyp) then
2439             iti1 = itortyp(itype(i-1))
2440           else
2441             iti1=ntortyp+1
2442           endif
2443         else
2444           iti1=ntortyp+1
2445         endif
2446         do k=1,2
2447           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2448         enddo
2449 cd        write (iout,*) 'mu ',mu(:,i-2)
2450 cd        write (iout,*) 'mu1',mu1(:,i-2)
2451 cd        write (iout,*) 'mu2',mu2(:,i-2)
2452         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2453      &  then
2454         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2455         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2456         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2457         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2458         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2459 C Vectors and matrices dependent on a single virtual-bond dihedral.
2460         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2461         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2462         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2463         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2464         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2465         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2466         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2467         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2468         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2469         endif
2470       enddo
2471 C Matrices dependent on two consecutive virtual-bond dihedrals.
2472 C The order of matrices is from left to right.
2473       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2474      &then
2475 c      do i=max0(ivec_start,2),ivec_end
2476       do i=2,nres-1
2477         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2478         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2479         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2480         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2481         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2482         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2483         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2484         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2485       enddo
2486       endif
2487 #if defined(MPI) && defined(PARMAT)
2488 #ifdef DEBUG
2489 c      if (fg_rank.eq.0) then
2490         write (iout,*) "Arrays UG and UGDER before GATHER"
2491         do i=1,nres-1
2492           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2493      &     ((ug(l,k,i),l=1,2),k=1,2),
2494      &     ((ugder(l,k,i),l=1,2),k=1,2)
2495         enddo
2496         write (iout,*) "Arrays UG2 and UG2DER"
2497         do i=1,nres-1
2498           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2499      &     ((ug2(l,k,i),l=1,2),k=1,2),
2500      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2501         enddo
2502         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2503         do i=1,nres-1
2504           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2505      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2506      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2507         enddo
2508         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2509         do i=1,nres-1
2510           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2511      &     costab(i),sintab(i),costab2(i),sintab2(i)
2512         enddo
2513         write (iout,*) "Array MUDER"
2514         do i=1,nres-1
2515           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2516         enddo
2517 c      endif
2518 #endif
2519       if (nfgtasks.gt.1) then
2520         time00=MPI_Wtime()
2521 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2522 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2523 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2524 #ifdef MATGATHER
2525         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2526      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2527      &   FG_COMM1,IERR)
2528         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2529      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2530      &   FG_COMM1,IERR)
2531         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2532      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2533      &   FG_COMM1,IERR)
2534         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2535      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2536      &   FG_COMM1,IERR)
2537         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2538      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2539      &   FG_COMM1,IERR)
2540         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2541      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2542      &   FG_COMM1,IERR)
2543         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2544      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2545      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2546         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2547      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2548      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2549         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2550      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2551      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2552         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2553      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2554      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2555         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2556      &  then
2557         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2558      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2559      &   FG_COMM1,IERR)
2560         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2561      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2562      &   FG_COMM1,IERR)
2563         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2564      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2565      &   FG_COMM1,IERR)
2566        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2567      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2568      &   FG_COMM1,IERR)
2569         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2570      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2571      &   FG_COMM1,IERR)
2572         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2573      &   ivec_count(fg_rank1),
2574      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2575      &   FG_COMM1,IERR)
2576         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2577      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2578      &   FG_COMM1,IERR)
2579         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2580      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2581      &   FG_COMM1,IERR)
2582         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2583      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2586      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2587      &   FG_COMM1,IERR)
2588         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2589      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2590      &   FG_COMM1,IERR)
2591         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2592      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2593      &   FG_COMM1,IERR)
2594         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2595      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2596      &   FG_COMM1,IERR)
2597         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2598      &   ivec_count(fg_rank1),
2599      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2600      &   FG_COMM1,IERR)
2601         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2602      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2603      &   FG_COMM1,IERR)
2604        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2605      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2606      &   FG_COMM1,IERR)
2607         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2608      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2609      &   FG_COMM1,IERR)
2610        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2611      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2612      &   FG_COMM1,IERR)
2613         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2614      &   ivec_count(fg_rank1),
2615      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2616      &   FG_COMM1,IERR)
2617         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2618      &   ivec_count(fg_rank1),
2619      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2622      &   ivec_count(fg_rank1),
2623      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2624      &   MPI_MAT2,FG_COMM1,IERR)
2625         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2626      &   ivec_count(fg_rank1),
2627      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2628      &   MPI_MAT2,FG_COMM1,IERR)
2629         endif
2630 #else
2631 c Passes matrix info through the ring
2632       isend=fg_rank1
2633       irecv=fg_rank1-1
2634       if (irecv.lt.0) irecv=nfgtasks1-1
2635       iprev=irecv
2636       inext=fg_rank1+1
2637       if (inext.ge.nfgtasks1) inext=0
2638       do i=1,nfgtasks1-1
2639 c        write (iout,*) "isend",isend," irecv",irecv
2640 c        call flush(iout)
2641         lensend=lentyp(isend)
2642         lenrecv=lentyp(irecv)
2643 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2644 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2645 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2646 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2647 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2648 c        write (iout,*) "Gather ROTAT1"
2649 c        call flush(iout)
2650 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2651 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2652 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2653 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2654 c        write (iout,*) "Gather ROTAT2"
2655 c        call flush(iout)
2656         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2657      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2658      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2659      &   iprev,4400+irecv,FG_COMM,status,IERR)
2660 c        write (iout,*) "Gather ROTAT_OLD"
2661 c        call flush(iout)
2662         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2663      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2664      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2665      &   iprev,5500+irecv,FG_COMM,status,IERR)
2666 c        write (iout,*) "Gather PRECOMP11"
2667 c        call flush(iout)
2668         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2669      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2670      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2671      &   iprev,6600+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather PRECOMP12"
2673 c        call flush(iout)
2674         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2675      &  then
2676         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2677      &   MPI_ROTAT2(lensend),inext,7700+isend,
2678      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2679      &   iprev,7700+irecv,FG_COMM,status,IERR)
2680 c        write (iout,*) "Gather PRECOMP21"
2681 c        call flush(iout)
2682         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2683      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2684      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2685      &   iprev,8800+irecv,FG_COMM,status,IERR)
2686 c        write (iout,*) "Gather PRECOMP22"
2687 c        call flush(iout)
2688         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2689      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2690      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2691      &   MPI_PRECOMP23(lenrecv),
2692      &   iprev,9900+irecv,FG_COMM,status,IERR)
2693 c        write (iout,*) "Gather PRECOMP23"
2694 c        call flush(iout)
2695         endif
2696         isend=irecv
2697         irecv=irecv-1
2698         if (irecv.lt.0) irecv=nfgtasks1-1
2699       enddo
2700 #endif
2701         time_gather=time_gather+MPI_Wtime()-time00
2702       endif
2703 #ifdef DEBUG
2704 c      if (fg_rank.eq.0) then
2705         write (iout,*) "Arrays UG and UGDER"
2706         do i=1,nres-1
2707           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2708      &     ((ug(l,k,i),l=1,2),k=1,2),
2709      &     ((ugder(l,k,i),l=1,2),k=1,2)
2710         enddo
2711         write (iout,*) "Arrays UG2 and UG2DER"
2712         do i=1,nres-1
2713           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2714      &     ((ug2(l,k,i),l=1,2),k=1,2),
2715      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2716         enddo
2717         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2718         do i=1,nres-1
2719           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2720      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2721      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2722         enddo
2723         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2724         do i=1,nres-1
2725           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2726      &     costab(i),sintab(i),costab2(i),sintab2(i)
2727         enddo
2728         write (iout,*) "Array MUDER"
2729         do i=1,nres-1
2730           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2731         enddo
2732 c      endif
2733 #endif
2734 #endif
2735 cd      do i=1,nres
2736 cd        iti = itortyp(itype(i))
2737 cd        write (iout,*) i
2738 cd        do j=1,2
2739 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2740 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2741 cd        enddo
2742 cd      enddo
2743       return
2744       end
2745 C--------------------------------------------------------------------------
2746       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2747 C
2748 C This subroutine calculates the average interaction energy and its gradient
2749 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2750 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2751 C The potential depends both on the distance of peptide-group centers and on
2752 C the orientation of the CA-CA virtual bonds.
2753 C
2754       implicit real*8 (a-h,o-z)
2755 #ifdef MPI
2756       include 'mpif.h'
2757 #endif
2758       include 'DIMENSIONS'
2759       include 'COMMON.CONTROL'
2760       include 'COMMON.SETUP'
2761       include 'COMMON.IOUNITS'
2762       include 'COMMON.GEO'
2763       include 'COMMON.VAR'
2764       include 'COMMON.LOCAL'
2765       include 'COMMON.CHAIN'
2766       include 'COMMON.DERIV'
2767       include 'COMMON.INTERACT'
2768       include 'COMMON.CONTACTS'
2769       include 'COMMON.TORSION'
2770       include 'COMMON.VECTORS'
2771       include 'COMMON.FFIELD'
2772       include 'COMMON.TIME1'
2773       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2774      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2775       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2776      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2777       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2778      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2779      &    num_conti,j1,j2
2780 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2781 #ifdef MOMENT
2782       double precision scal_el /1.0d0/
2783 #else
2784       double precision scal_el /0.5d0/
2785 #endif
2786 C 12/13/98
2787 C 13-go grudnia roku pamietnego...
2788       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2789      &                   0.0d0,1.0d0,0.0d0,
2790      &                   0.0d0,0.0d0,1.0d0/
2791 cd      write(iout,*) 'In EELEC'
2792 cd      do i=1,nloctyp
2793 cd        write(iout,*) 'Type',i
2794 cd        write(iout,*) 'B1',B1(:,i)
2795 cd        write(iout,*) 'B2',B2(:,i)
2796 cd        write(iout,*) 'CC',CC(:,:,i)
2797 cd        write(iout,*) 'DD',DD(:,:,i)
2798 cd        write(iout,*) 'EE',EE(:,:,i)
2799 cd      enddo
2800 cd      call check_vecgrad
2801 cd      stop
2802       if (icheckgrad.eq.1) then
2803         do i=1,nres-1
2804           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2805           do k=1,3
2806             dc_norm(k,i)=dc(k,i)*fac
2807           enddo
2808 c          write (iout,*) 'i',i,' fac',fac
2809         enddo
2810       endif
2811       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2812      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2813      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2814 c        call vec_and_deriv
2815 #ifdef TIMING
2816         time01=MPI_Wtime()
2817 #endif
2818         call set_matrices
2819 #ifdef TIMING
2820         time_mat=time_mat+MPI_Wtime()-time01
2821 #endif
2822       endif
2823 cd      do i=1,nres-1
2824 cd        write (iout,*) 'i=',i
2825 cd        do k=1,3
2826 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2827 cd        enddo
2828 cd        do k=1,3
2829 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2830 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2831 cd        enddo
2832 cd      enddo
2833       t_eelecij=0.0d0
2834       ees=0.0D0
2835       evdw1=0.0D0
2836       eel_loc=0.0d0
2837       eello_turn3=0.0d0
2838       eello_turn4=0.0d0
2839       ind=0
2840       do i=1,nres
2841         num_cont_hb(i)=0
2842       enddo
2843 cd      print '(a)','Enter EELEC'
2844 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2845       do i=1,nres
2846         gel_loc_loc(i)=0.0d0
2847         gcorr_loc(i)=0.0d0
2848       enddo
2849 c
2850 c
2851 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2852 C
2853 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2854 C
2855 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2856       do i=iturn3_start,iturn3_end
2857         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2858      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2859         dxi=dc(1,i)
2860         dyi=dc(2,i)
2861         dzi=dc(3,i)
2862         dx_normi=dc_norm(1,i)
2863         dy_normi=dc_norm(2,i)
2864         dz_normi=dc_norm(3,i)
2865         xmedi=c(1,i)+0.5d0*dxi
2866         ymedi=c(2,i)+0.5d0*dyi
2867         zmedi=c(3,i)+0.5d0*dzi
2868 C Return atom into box, boxxsize is size of box in x dimension
2869   184   continue
2870         if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2871         if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2872 C Condition for being inside the proper box
2873         if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2874      &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2875         go to 184
2876         endif
2877   185   continue
2878         if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2879         if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2880 C Condition for being inside the proper box
2881         if ((ymedi.gt.((0.5d0)*boxysize)).or.
2882      &       (ymedi.lt.((-0.5d0)*boxysize))) then
2883         go to 185
2884         endif
2885   186   continue
2886         if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxxsize
2887         if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxxsize
2888 C Condition for being inside the proper box
2889         if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2890      &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2891         go to 186
2892         endif
2893         num_conti=0
2894         call eelecij(i,i+2,ees,evdw1,eel_loc)
2895         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2896         num_cont_hb(i)=num_conti
2897       enddo
2898       do i=iturn4_start,iturn4_end
2899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2900      &    .or. itype(i+3).eq.ntyp1
2901      &    .or. itype(i+4).eq.ntyp1) cycle
2902         dxi=dc(1,i)
2903         dyi=dc(2,i)
2904         dzi=dc(3,i)
2905         dx_normi=dc_norm(1,i)
2906         dy_normi=dc_norm(2,i)
2907         dz_normi=dc_norm(3,i)
2908         xmedi=c(1,i)+0.5d0*dxi
2909         ymedi=c(2,i)+0.5d0*dyi
2910         zmedi=c(3,i)+0.5d0*dzi
2911 C Return atom into box, boxxsize is size of box in x dimension
2912   194   continue
2913         if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2914         if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2915 C Condition for being inside the proper box
2916         if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2917      &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2918         go to 194
2919         endif
2920   195   continue
2921         if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2922         if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2923 C Condition for being inside the proper box
2924         if ((ymedi.gt.((0.5d0)*boxysize)).or.
2925      &       (ymedi.lt.((-0.5d0)*boxysize))) then
2926         go to 195
2927         endif
2928   196   continue
2929         if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxxsize
2930         if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxxsize
2931 C Condition for being inside the proper box
2932         if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2933      &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2934         go to 196
2935         endif
2936
2937         num_conti=num_cont_hb(i)
2938         call eelecij(i,i+3,ees,evdw1,eel_loc)
2939         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2940      &   call eturn4(i,eello_turn4)
2941         num_cont_hb(i)=num_conti
2942       enddo   ! i
2943 C Loop over all neighbouring boxes
2944       do xshift=-1,1
2945       do yshift=-1,1
2946       do zshift=-1,1
2947 c
2948 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2949 c
2950       do i=iatel_s,iatel_e
2951         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2952         dxi=dc(1,i)
2953         dyi=dc(2,i)
2954         dzi=dc(3,i)
2955         dx_normi=dc_norm(1,i)
2956         dy_normi=dc_norm(2,i)
2957         dz_normi=dc_norm(3,i)
2958         xmedi=c(1,i)+0.5d0*dxi
2959         ymedi=c(2,i)+0.5d0*dyi
2960         zmedi=c(3,i)+0.5d0*dzi
2961 C Return atom into box, boxxsize is size of box in x dimension
2962   164   continue
2963         if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2964         if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2965 C Condition for being inside the proper box
2966         if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2967      &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2968         go to 164
2969         endif
2970   165   continue
2971         if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2972         if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2973 C Condition for being inside the proper box
2974         if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2975      &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2976         go to 165
2977         endif
2978   166   continue
2979         if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxxsize
2980         if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxxsize
2981 C Condition for being inside the proper box
2982         if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2983      &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2984         go to 166
2985         endif
2986
2987 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2988         num_conti=num_cont_hb(i)
2989         do j=ielstart(i),ielend(i)
2990 c          write (iout,*) i,j,itype(i),itype(j)
2991           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2992           call eelecij(i,j,ees,evdw1,eel_loc)
2993         enddo ! j
2994         num_cont_hb(i)=num_conti
2995       enddo   ! i
2996       enddo   ! zshift
2997       enddo   ! yshift
2998       enddo   ! xshift
2999
3000 c      write (iout,*) "Number of loop steps in EELEC:",ind
3001 cd      do i=1,nres
3002 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3003 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3004 cd      enddo
3005 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3006 ccc      eel_loc=eel_loc+eello_turn3
3007 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3008       return
3009       end
3010 C-------------------------------------------------------------------------------
3011       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3012       implicit real*8 (a-h,o-z)
3013       include 'DIMENSIONS'
3014 #ifdef MPI
3015       include "mpif.h"
3016 #endif
3017       include 'COMMON.CONTROL'
3018       include 'COMMON.IOUNITS'
3019       include 'COMMON.GEO'
3020       include 'COMMON.VAR'
3021       include 'COMMON.LOCAL'
3022       include 'COMMON.CHAIN'
3023       include 'COMMON.DERIV'
3024       include 'COMMON.INTERACT'
3025       include 'COMMON.CONTACTS'
3026       include 'COMMON.TORSION'
3027       include 'COMMON.VECTORS'
3028       include 'COMMON.FFIELD'
3029       include 'COMMON.TIME1'
3030       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3031      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3032       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3033      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3034       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3035      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3036      &    num_conti,j1,j2
3037 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3038 #ifdef MOMENT
3039       double precision scal_el /1.0d0/
3040 #else
3041       double precision scal_el /0.5d0/
3042 #endif
3043 C 12/13/98
3044 C 13-go grudnia roku pamietnego...
3045       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3046      &                   0.0d0,1.0d0,0.0d0,
3047      &                   0.0d0,0.0d0,1.0d0/
3048 c          time00=MPI_Wtime()
3049 cd      write (iout,*) "eelecij",i,j
3050 c          ind=ind+1
3051           iteli=itel(i)
3052           itelj=itel(j)
3053           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3054           aaa=app(iteli,itelj)
3055           bbb=bpp(iteli,itelj)
3056           ael6i=ael6(iteli,itelj)
3057           ael3i=ael3(iteli,itelj)
3058           dxj=dc(1,j)
3059           dyj=dc(2,j)
3060           dzj=dc(3,j)
3061           dx_normj=dc_norm(1,j)
3062           dy_normj=dc_norm(2,j)
3063           dz_normj=dc_norm(3,j)
3064 C          xj=c(1,j)+0.5D0*dxj-xmedi
3065 C          yj=c(2,j)+0.5D0*dyj-ymedi
3066 C          zj=c(3,j)+0.5D0*dzj-zmedi
3067           xj=c(1,j)+0.5D0*dxj
3068           yj=c(2,j)+0.5D0*dyj
3069           zj=c(3,j)+0.5D0*dzj
3070 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3071   174   continue
3072         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3073         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3074 C Condition for being inside the proper box
3075         if ((xj.gt.((0.5d0)*boxxsize)).or.
3076      &       (xj.lt.((-0.5d0)*boxxsize))) then
3077         go to 174
3078         endif
3079   175   continue
3080         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3081         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3082 C Condition for being inside the proper box
3083         if ((yj.gt.((0.5d0)*boxysize)).or.
3084      &       (yj.lt.((-0.5d0)*boxysize))) then
3085         go to 175
3086         endif
3087   176   continue
3088         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxxsize
3089         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxxsize
3090 C Condition for being inside the proper box
3091         if ((zj.gt.((0.5d0)*boxzsize)).or.
3092      &       (zj.lt.((-0.5d0)*boxzsize))) then
3093         go to 176
3094         endif
3095 C        endif !endPBC condintion
3096         xj=xj-xmedi
3097         yj=yj-ymedi
3098         zj=zj-zmedi
3099           rij=xj*xj+yj*yj+zj*zj
3100           rrmij=1.0D0/rij
3101           rij=dsqrt(rij)
3102           rmij=1.0D0/rij
3103           r3ij=rrmij*rmij
3104           r6ij=r3ij*r3ij
3105           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3106           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3107           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3108           fac=cosa-3.0D0*cosb*cosg
3109           ev1=aaa*r6ij*r6ij
3110 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3111           if (j.eq.i+2) ev1=scal_el*ev1
3112           ev2=bbb*r6ij
3113           fac3=ael6i*r6ij
3114           fac4=ael3i*r3ij
3115           evdwij=ev1+ev2
3116           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3117           el2=fac4*fac
3118           eesij=el1+el2
3119 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3120           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3121           ees=ees+eesij
3122           evdw1=evdw1+evdwij
3123 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3124 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3125 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3126 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3127
3128           if (energy_dec) then
3129               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3130      &'evdw1',i,j,evdwij
3131      &,iteli,itelj,aaa,evdw1
3132               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3133           endif
3134
3135 C
3136 C Calculate contributions to the Cartesian gradient.
3137 C
3138 #ifdef SPLITELE
3139           facvdw=-6*rrmij*(ev1+evdwij)
3140           facel=-3*rrmij*(el1+eesij)
3141           fac1=fac
3142           erij(1)=xj*rmij
3143           erij(2)=yj*rmij
3144           erij(3)=zj*rmij
3145 *
3146 * Radial derivatives. First process both termini of the fragment (i,j)
3147 *
3148           ggg(1)=facel*xj
3149           ggg(2)=facel*yj
3150           ggg(3)=facel*zj
3151 c          do k=1,3
3152 c            ghalf=0.5D0*ggg(k)
3153 c            gelc(k,i)=gelc(k,i)+ghalf
3154 c            gelc(k,j)=gelc(k,j)+ghalf
3155 c          enddo
3156 c 9/28/08 AL Gradient compotents will be summed only at the end
3157           do k=1,3
3158             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3159             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3160           enddo
3161 *
3162 * Loop over residues i+1 thru j-1.
3163 *
3164 cgrad          do k=i+1,j-1
3165 cgrad            do l=1,3
3166 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3167 cgrad            enddo
3168 cgrad          enddo
3169           ggg(1)=facvdw*xj
3170           ggg(2)=facvdw*yj
3171           ggg(3)=facvdw*zj
3172 c          do k=1,3
3173 c            ghalf=0.5D0*ggg(k)
3174 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3175 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3176 c          enddo
3177 c 9/28/08 AL Gradient compotents will be summed only at the end
3178           do k=1,3
3179             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3180             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3181           enddo
3182 *
3183 * Loop over residues i+1 thru j-1.
3184 *
3185 cgrad          do k=i+1,j-1
3186 cgrad            do l=1,3
3187 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3188 cgrad            enddo
3189 cgrad          enddo
3190 #else
3191           facvdw=ev1+evdwij
3192           facel=el1+eesij
3193           fac1=fac
3194           fac=-3*rrmij*(facvdw+facvdw+facel)
3195           erij(1)=xj*rmij
3196           erij(2)=yj*rmij
3197           erij(3)=zj*rmij
3198 *
3199 * Radial derivatives. First process both termini of the fragment (i,j)
3200 *
3201           ggg(1)=fac*xj
3202           ggg(2)=fac*yj
3203           ggg(3)=fac*zj
3204 c          do k=1,3
3205 c            ghalf=0.5D0*ggg(k)
3206 c            gelc(k,i)=gelc(k,i)+ghalf
3207 c            gelc(k,j)=gelc(k,j)+ghalf
3208 c          enddo
3209 c 9/28/08 AL Gradient compotents will be summed only at the end
3210           do k=1,3
3211             gelc_long(k,j)=gelc(k,j)+ggg(k)
3212             gelc_long(k,i)=gelc(k,i)-ggg(k)
3213           enddo
3214 *
3215 * Loop over residues i+1 thru j-1.
3216 *
3217 cgrad          do k=i+1,j-1
3218 cgrad            do l=1,3
3219 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3220 cgrad            enddo
3221 cgrad          enddo
3222 c 9/28/08 AL Gradient compotents will be summed only at the end
3223           ggg(1)=facvdw*xj
3224           ggg(2)=facvdw*yj
3225           ggg(3)=facvdw*zj
3226           do k=1,3
3227             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3228             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3229           enddo
3230 #endif
3231 *
3232 * Angular part
3233 *
3234           ecosa=2.0D0*fac3*fac1+fac4
3235           fac4=-3.0D0*fac4
3236           fac3=-6.0D0*fac3
3237           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3238           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3239           do k=1,3
3240             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3241             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3242           enddo
3243 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3244 cd   &          (dcosg(k),k=1,3)
3245           do k=1,3
3246             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3247           enddo
3248 c          do k=1,3
3249 c            ghalf=0.5D0*ggg(k)
3250 c            gelc(k,i)=gelc(k,i)+ghalf
3251 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3252 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3253 c            gelc(k,j)=gelc(k,j)+ghalf
3254 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3255 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3256 c          enddo
3257 cgrad          do k=i+1,j-1
3258 cgrad            do l=1,3
3259 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3260 cgrad            enddo
3261 cgrad          enddo
3262           do k=1,3
3263             gelc(k,i)=gelc(k,i)
3264      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3265      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3266             gelc(k,j)=gelc(k,j)
3267      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3268      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3269             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3270             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3271           enddo
3272           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3273      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3274      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3275 C
3276 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3277 C   energy of a peptide unit is assumed in the form of a second-order
3278 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3279 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3280 C   are computed for EVERY pair of non-contiguous peptide groups.
3281 C
3282           if (j.lt.nres-1) then
3283             j1=j+1
3284             j2=j-1
3285           else
3286             j1=j-1
3287             j2=j-2
3288           endif
3289           kkk=0
3290           do k=1,2
3291             do l=1,2
3292               kkk=kkk+1
3293               muij(kkk)=mu(k,i)*mu(l,j)
3294             enddo
3295           enddo
3296 cd         write (iout,*) 'EELEC: i',i,' j',j
3297 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3298 cd          write(iout,*) 'muij',muij
3299           ury=scalar(uy(1,i),erij)
3300           urz=scalar(uz(1,i),erij)
3301           vry=scalar(uy(1,j),erij)
3302           vrz=scalar(uz(1,j),erij)
3303           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3304           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3305           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3306           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3307           fac=dsqrt(-ael6i)*r3ij
3308           a22=a22*fac
3309           a23=a23*fac
3310           a32=a32*fac
3311           a33=a33*fac
3312 cd          write (iout,'(4i5,4f10.5)')
3313 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3314 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3315 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3316 cd     &      uy(:,j),uz(:,j)
3317 cd          write (iout,'(4f10.5)')
3318 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3319 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3320 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3321 cd           write (iout,'(9f10.5/)')
3322 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3323 C Derivatives of the elements of A in virtual-bond vectors
3324           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3325           do k=1,3
3326             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3327             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3328             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3329             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3330             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3331             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3332             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3333             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3334             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3335             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3336             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3337             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3338           enddo
3339 C Compute radial contributions to the gradient
3340           facr=-3.0d0*rrmij
3341           a22der=a22*facr
3342           a23der=a23*facr
3343           a32der=a32*facr
3344           a33der=a33*facr
3345           agg(1,1)=a22der*xj
3346           agg(2,1)=a22der*yj
3347           agg(3,1)=a22der*zj
3348           agg(1,2)=a23der*xj
3349           agg(2,2)=a23der*yj
3350           agg(3,2)=a23der*zj
3351           agg(1,3)=a32der*xj
3352           agg(2,3)=a32der*yj
3353           agg(3,3)=a32der*zj
3354           agg(1,4)=a33der*xj
3355           agg(2,4)=a33der*yj
3356           agg(3,4)=a33der*zj
3357 C Add the contributions coming from er
3358           fac3=-3.0d0*fac
3359           do k=1,3
3360             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3361             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3362             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3363             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3364           enddo
3365           do k=1,3
3366 C Derivatives in DC(i)
3367 cgrad            ghalf1=0.5d0*agg(k,1)
3368 cgrad            ghalf2=0.5d0*agg(k,2)
3369 cgrad            ghalf3=0.5d0*agg(k,3)
3370 cgrad            ghalf4=0.5d0*agg(k,4)
3371             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3372      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3373             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3374      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3375             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3376      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3377             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3378      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3379 C Derivatives in DC(i+1)
3380             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3381      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3382             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3383      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3384             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3385      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3386             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3387      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3388 C Derivatives in DC(j)
3389             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3390      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3391             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3392      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3393             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3394      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3395             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3396      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3397 C Derivatives in DC(j+1) or DC(nres-1)
3398             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3399      &      -3.0d0*vryg(k,3)*ury)
3400             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3401      &      -3.0d0*vrzg(k,3)*ury)
3402             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3403      &      -3.0d0*vryg(k,3)*urz)
3404             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3405      &      -3.0d0*vrzg(k,3)*urz)
3406 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3407 cgrad              do l=1,4
3408 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3409 cgrad              enddo
3410 cgrad            endif
3411           enddo
3412           acipa(1,1)=a22
3413           acipa(1,2)=a23
3414           acipa(2,1)=a32
3415           acipa(2,2)=a33
3416           a22=-a22
3417           a23=-a23
3418           do l=1,2
3419             do k=1,3
3420               agg(k,l)=-agg(k,l)
3421               aggi(k,l)=-aggi(k,l)
3422               aggi1(k,l)=-aggi1(k,l)
3423               aggj(k,l)=-aggj(k,l)
3424               aggj1(k,l)=-aggj1(k,l)
3425             enddo
3426           enddo
3427           if (j.lt.nres-1) then
3428             a22=-a22
3429             a32=-a32
3430             do l=1,3,2
3431               do k=1,3
3432                 agg(k,l)=-agg(k,l)
3433                 aggi(k,l)=-aggi(k,l)
3434                 aggi1(k,l)=-aggi1(k,l)
3435                 aggj(k,l)=-aggj(k,l)
3436                 aggj1(k,l)=-aggj1(k,l)
3437               enddo
3438             enddo
3439           else
3440             a22=-a22
3441             a23=-a23
3442             a32=-a32
3443             a33=-a33
3444             do l=1,4
3445               do k=1,3
3446                 agg(k,l)=-agg(k,l)
3447                 aggi(k,l)=-aggi(k,l)
3448                 aggi1(k,l)=-aggi1(k,l)
3449                 aggj(k,l)=-aggj(k,l)
3450                 aggj1(k,l)=-aggj1(k,l)
3451               enddo
3452             enddo
3453           endif
3454           ENDIF ! WCORR
3455           IF (wel_loc.gt.0.0d0) THEN
3456 C Contribution to the local-electrostatic energy coming from the i-j pair
3457           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3458      &     +a33*muij(4)
3459 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3460
3461           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3462      &            'eelloc',i,j,eel_loc_ij
3463            if (eel_loc_ij.ne.0)
3464      &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3465      &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3466
3467           eel_loc=eel_loc+eel_loc_ij
3468 C Partial derivatives in virtual-bond dihedral angles gamma
3469           if (i.gt.1)
3470      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3471      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3472      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3473           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3474      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3475      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3476 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3477           do l=1,3
3478             ggg(l)=agg(l,1)*muij(1)+
3479      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3480             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3481             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3482 cgrad            ghalf=0.5d0*ggg(l)
3483 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3484 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3485           enddo
3486 cgrad          do k=i+1,j2
3487 cgrad            do l=1,3
3488 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3489 cgrad            enddo
3490 cgrad          enddo
3491 C Remaining derivatives of eello
3492           do l=1,3
3493             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3494      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3495             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3496      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3497             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3498      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3499             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3500      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3501           enddo
3502           ENDIF
3503 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3504 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3505           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3506      &       .and. num_conti.le.maxconts) then
3507 c            write (iout,*) i,j," entered corr"
3508 C
3509 C Calculate the contact function. The ith column of the array JCONT will
3510 C contain the numbers of atoms that make contacts with the atom I (of numbers
3511 C greater than I). The arrays FACONT and GACONT will contain the values of
3512 C the contact function and its derivative.
3513 c           r0ij=1.02D0*rpp(iteli,itelj)
3514 c           r0ij=1.11D0*rpp(iteli,itelj)
3515             r0ij=2.20D0*rpp(iteli,itelj)
3516 c           r0ij=1.55D0*rpp(iteli,itelj)
3517             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3518             if (fcont.gt.0.0D0) then
3519               num_conti=num_conti+1
3520               if (num_conti.gt.maxconts) then
3521                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3522      &                         ' will skip next contacts for this conf.'
3523               else
3524                 jcont_hb(num_conti,i)=j
3525 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3526 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3527                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3528      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3529 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3530 C  terms.
3531                 d_cont(num_conti,i)=rij
3532 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3533 C     --- Electrostatic-interaction matrix ---
3534                 a_chuj(1,1,num_conti,i)=a22
3535                 a_chuj(1,2,num_conti,i)=a23
3536                 a_chuj(2,1,num_conti,i)=a32
3537                 a_chuj(2,2,num_conti,i)=a33
3538 C     --- Gradient of rij
3539                 do kkk=1,3
3540                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3541                 enddo
3542                 kkll=0
3543                 do k=1,2
3544                   do l=1,2
3545                     kkll=kkll+1
3546                     do m=1,3
3547                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3548                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3549                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3550                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3551                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3552                     enddo
3553                   enddo
3554                 enddo
3555                 ENDIF
3556                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3557 C Calculate contact energies
3558                 cosa4=4.0D0*cosa
3559                 wij=cosa-3.0D0*cosb*cosg
3560                 cosbg1=cosb+cosg
3561                 cosbg2=cosb-cosg
3562 c               fac3=dsqrt(-ael6i)/r0ij**3
3563                 fac3=dsqrt(-ael6i)*r3ij
3564 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3565                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3566                 if (ees0tmp.gt.0) then
3567                   ees0pij=dsqrt(ees0tmp)
3568                 else
3569                   ees0pij=0
3570                 endif
3571 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3572                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3573                 if (ees0tmp.gt.0) then
3574                   ees0mij=dsqrt(ees0tmp)
3575                 else
3576                   ees0mij=0
3577                 endif
3578 c               ees0mij=0.0D0
3579                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3580                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3581 C Diagnostics. Comment out or remove after debugging!
3582 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3583 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3584 c               ees0m(num_conti,i)=0.0D0
3585 C End diagnostics.
3586 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3587 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3588 C Angular derivatives of the contact function
3589                 ees0pij1=fac3/ees0pij
3590                 ees0mij1=fac3/ees0mij
3591                 fac3p=-3.0D0*fac3*rrmij
3592                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3593                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3594 c               ees0mij1=0.0D0
3595                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3596                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3597                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3598                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3599                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3600                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3601                 ecosap=ecosa1+ecosa2
3602                 ecosbp=ecosb1+ecosb2
3603                 ecosgp=ecosg1+ecosg2
3604                 ecosam=ecosa1-ecosa2
3605                 ecosbm=ecosb1-ecosb2
3606                 ecosgm=ecosg1-ecosg2
3607 C Diagnostics
3608 c               ecosap=ecosa1
3609 c               ecosbp=ecosb1
3610 c               ecosgp=ecosg1
3611 c               ecosam=0.0D0
3612 c               ecosbm=0.0D0
3613 c               ecosgm=0.0D0
3614 C End diagnostics
3615                 facont_hb(num_conti,i)=fcont
3616                 fprimcont=fprimcont/rij
3617 cd              facont_hb(num_conti,i)=1.0D0
3618 C Following line is for diagnostics.
3619 cd              fprimcont=0.0D0
3620                 do k=1,3
3621                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3622                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3623                 enddo
3624                 do k=1,3
3625                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3626                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3627                 enddo
3628                 gggp(1)=gggp(1)+ees0pijp*xj
3629                 gggp(2)=gggp(2)+ees0pijp*yj
3630                 gggp(3)=gggp(3)+ees0pijp*zj
3631                 gggm(1)=gggm(1)+ees0mijp*xj
3632                 gggm(2)=gggm(2)+ees0mijp*yj
3633                 gggm(3)=gggm(3)+ees0mijp*zj
3634 C Derivatives due to the contact function
3635                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3636                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3637                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3638                 do k=1,3
3639 c
3640 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3641 c          following the change of gradient-summation algorithm.
3642 c
3643 cgrad                  ghalfp=0.5D0*gggp(k)
3644 cgrad                  ghalfm=0.5D0*gggm(k)
3645                   gacontp_hb1(k,num_conti,i)=!ghalfp
3646      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3647      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3648                   gacontp_hb2(k,num_conti,i)=!ghalfp
3649      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3650      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3651                   gacontp_hb3(k,num_conti,i)=gggp(k)
3652                   gacontm_hb1(k,num_conti,i)=!ghalfm
3653      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3654      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3655                   gacontm_hb2(k,num_conti,i)=!ghalfm
3656      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3657      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3658                   gacontm_hb3(k,num_conti,i)=gggm(k)
3659                 enddo
3660 C Diagnostics. Comment out or remove after debugging!
3661 cdiag           do k=1,3
3662 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3663 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3664 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3665 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3666 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3667 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3668 cdiag           enddo
3669               ENDIF ! wcorr
3670               endif  ! num_conti.le.maxconts
3671             endif  ! fcont.gt.0
3672           endif    ! j.gt.i+1
3673           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3674             do k=1,4
3675               do l=1,3
3676                 ghalf=0.5d0*agg(l,k)
3677                 aggi(l,k)=aggi(l,k)+ghalf
3678                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3679                 aggj(l,k)=aggj(l,k)+ghalf
3680               enddo
3681             enddo
3682             if (j.eq.nres-1 .and. i.lt.j-2) then
3683               do k=1,4
3684                 do l=1,3
3685                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3686                 enddo
3687               enddo
3688             endif
3689           endif
3690 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3691       return
3692       end
3693 C-----------------------------------------------------------------------------
3694       subroutine eturn3(i,eello_turn3)
3695 C Third- and fourth-order contributions from turns
3696       implicit real*8 (a-h,o-z)
3697       include 'DIMENSIONS'
3698       include 'COMMON.IOUNITS'
3699       include 'COMMON.GEO'
3700       include 'COMMON.VAR'
3701       include 'COMMON.LOCAL'
3702       include 'COMMON.CHAIN'
3703       include 'COMMON.DERIV'
3704       include 'COMMON.INTERACT'
3705       include 'COMMON.CONTACTS'
3706       include 'COMMON.TORSION'
3707       include 'COMMON.VECTORS'
3708       include 'COMMON.FFIELD'
3709       include 'COMMON.CONTROL'
3710       dimension ggg(3)
3711       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3712      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3713      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3714       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3715      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3716       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3717      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3718      &    num_conti,j1,j2
3719       j=i+2
3720 c      write (iout,*) "eturn3",i,j,j1,j2
3721       a_temp(1,1)=a22
3722       a_temp(1,2)=a23
3723       a_temp(2,1)=a32
3724       a_temp(2,2)=a33
3725 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3726 C
3727 C               Third-order contributions
3728 C
3729 C                 (i+2)o----(i+3)
3730 C                      | |
3731 C                      | |
3732 C                 (i+1)o----i
3733 C
3734 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3735 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3736         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3737         call transpose2(auxmat(1,1),auxmat1(1,1))
3738         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3739         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3740         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3741      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3742 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3743 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3744 cd     &    ' eello_turn3_num',4*eello_turn3_num
3745 C Derivatives in gamma(i)
3746         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3747         call transpose2(auxmat2(1,1),auxmat3(1,1))
3748         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3749         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3750 C Derivatives in gamma(i+1)
3751         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3752         call transpose2(auxmat2(1,1),auxmat3(1,1))
3753         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3754         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3755      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3756 C Cartesian derivatives
3757         do l=1,3
3758 c            ghalf1=0.5d0*agg(l,1)
3759 c            ghalf2=0.5d0*agg(l,2)
3760 c            ghalf3=0.5d0*agg(l,3)
3761 c            ghalf4=0.5d0*agg(l,4)
3762           a_temp(1,1)=aggi(l,1)!+ghalf1
3763           a_temp(1,2)=aggi(l,2)!+ghalf2
3764           a_temp(2,1)=aggi(l,3)!+ghalf3
3765           a_temp(2,2)=aggi(l,4)!+ghalf4
3766           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3767           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3768      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3769           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3770           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3771           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3772           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3773           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3774           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3775      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3776           a_temp(1,1)=aggj(l,1)!+ghalf1
3777           a_temp(1,2)=aggj(l,2)!+ghalf2
3778           a_temp(2,1)=aggj(l,3)!+ghalf3
3779           a_temp(2,2)=aggj(l,4)!+ghalf4
3780           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3781           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3782      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3783           a_temp(1,1)=aggj1(l,1)
3784           a_temp(1,2)=aggj1(l,2)
3785           a_temp(2,1)=aggj1(l,3)
3786           a_temp(2,2)=aggj1(l,4)
3787           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3788           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3789      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3790         enddo
3791       return
3792       end
3793 C-------------------------------------------------------------------------------
3794       subroutine eturn4(i,eello_turn4)
3795 C Third- and fourth-order contributions from turns
3796       implicit real*8 (a-h,o-z)
3797       include 'DIMENSIONS'
3798       include 'COMMON.IOUNITS'
3799       include 'COMMON.GEO'
3800       include 'COMMON.VAR'
3801       include 'COMMON.LOCAL'
3802       include 'COMMON.CHAIN'
3803       include 'COMMON.DERIV'
3804       include 'COMMON.INTERACT'
3805       include 'COMMON.CONTACTS'
3806       include 'COMMON.TORSION'
3807       include 'COMMON.VECTORS'
3808       include 'COMMON.FFIELD'
3809       include 'COMMON.CONTROL'
3810       dimension ggg(3)
3811       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3812      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3813      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3814       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3815      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3816       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3817      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3818      &    num_conti,j1,j2
3819       j=i+3
3820 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3821 C
3822 C               Fourth-order contributions
3823 C
3824 C                 (i+3)o----(i+4)
3825 C                     /  |
3826 C               (i+2)o   |
3827 C                     \  |
3828 C                 (i+1)o----i
3829 C
3830 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3831 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3832 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3833         a_temp(1,1)=a22
3834         a_temp(1,2)=a23
3835         a_temp(2,1)=a32
3836         a_temp(2,2)=a33
3837         iti1=itortyp(itype(i+1))
3838         iti2=itortyp(itype(i+2))
3839         iti3=itortyp(itype(i+3))
3840 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3841         call transpose2(EUg(1,1,i+1),e1t(1,1))
3842         call transpose2(Eug(1,1,i+2),e2t(1,1))
3843         call transpose2(Eug(1,1,i+3),e3t(1,1))
3844         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3845         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3846         s1=scalar2(b1(1,iti2),auxvec(1))
3847         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3848         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3849         s2=scalar2(b1(1,iti1),auxvec(1))
3850         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3851         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3852         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3853         eello_turn4=eello_turn4-(s1+s2+s3)
3854 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3855         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3856      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3857 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3858 cd     &    ' eello_turn4_num',8*eello_turn4_num
3859 C Derivatives in gamma(i)
3860         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3861         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3862         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3863         s1=scalar2(b1(1,iti2),auxvec(1))
3864         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3865         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3867 C Derivatives in gamma(i+1)
3868         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3869         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3870         s2=scalar2(b1(1,iti1),auxvec(1))
3871         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3872         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3873         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3874         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3875 C Derivatives in gamma(i+2)
3876         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3877         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3878         s1=scalar2(b1(1,iti2),auxvec(1))
3879         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3880         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3881         s2=scalar2(b1(1,iti1),auxvec(1))
3882         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3883         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3886 C Cartesian derivatives
3887 C Derivatives of this turn contributions in DC(i+2)
3888         if (j.lt.nres-1) then
3889           do l=1,3
3890             a_temp(1,1)=agg(l,1)
3891             a_temp(1,2)=agg(l,2)
3892             a_temp(2,1)=agg(l,3)
3893             a_temp(2,2)=agg(l,4)
3894             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3895             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3896             s1=scalar2(b1(1,iti2),auxvec(1))
3897             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3898             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3899             s2=scalar2(b1(1,iti1),auxvec(1))
3900             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3901             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3902             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3903             ggg(l)=-(s1+s2+s3)
3904             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3905           enddo
3906         endif
3907 C Remaining derivatives of this turn contribution
3908         do l=1,3
3909           a_temp(1,1)=aggi(l,1)
3910           a_temp(1,2)=aggi(l,2)
3911           a_temp(2,1)=aggi(l,3)
3912           a_temp(2,2)=aggi(l,4)
3913           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3914           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3915           s1=scalar2(b1(1,iti2),auxvec(1))
3916           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3917           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3918           s2=scalar2(b1(1,iti1),auxvec(1))
3919           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3920           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3921           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3923           a_temp(1,1)=aggi1(l,1)
3924           a_temp(1,2)=aggi1(l,2)
3925           a_temp(2,1)=aggi1(l,3)
3926           a_temp(2,2)=aggi1(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,iti2),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,iti1),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           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3937           a_temp(1,1)=aggj(l,1)
3938           a_temp(1,2)=aggj(l,2)
3939           a_temp(2,1)=aggj(l,3)
3940           a_temp(2,2)=aggj(l,4)
3941           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3942           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3943           s1=scalar2(b1(1,iti2),auxvec(1))
3944           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3945           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3946           s2=scalar2(b1(1,iti1),auxvec(1))
3947           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3948           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3949           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3950           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3951           a_temp(1,1)=aggj1(l,1)
3952           a_temp(1,2)=aggj1(l,2)
3953           a_temp(2,1)=aggj1(l,3)
3954           a_temp(2,2)=aggj1(l,4)
3955           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3956           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3957           s1=scalar2(b1(1,iti2),auxvec(1))
3958           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3959           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3960           s2=scalar2(b1(1,iti1),auxvec(1))
3961           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3962           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3963           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3964 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3965           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3966         enddo
3967       return
3968       end
3969 C-----------------------------------------------------------------------------
3970       subroutine vecpr(u,v,w)
3971       implicit real*8(a-h,o-z)
3972       dimension u(3),v(3),w(3)
3973       w(1)=u(2)*v(3)-u(3)*v(2)
3974       w(2)=-u(1)*v(3)+u(3)*v(1)
3975       w(3)=u(1)*v(2)-u(2)*v(1)
3976       return
3977       end
3978 C-----------------------------------------------------------------------------
3979       subroutine unormderiv(u,ugrad,unorm,ungrad)
3980 C This subroutine computes the derivatives of a normalized vector u, given
3981 C the derivatives computed without normalization conditions, ugrad. Returns
3982 C ungrad.
3983       implicit none
3984       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3985       double precision vec(3)
3986       double precision scalar
3987       integer i,j
3988 c      write (2,*) 'ugrad',ugrad
3989 c      write (2,*) 'u',u
3990       do i=1,3
3991         vec(i)=scalar(ugrad(1,i),u(1))
3992       enddo
3993 c      write (2,*) 'vec',vec
3994       do i=1,3
3995         do j=1,3
3996           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3997         enddo
3998       enddo
3999 c      write (2,*) 'ungrad',ungrad
4000       return
4001       end
4002 C-----------------------------------------------------------------------------
4003       subroutine escp_soft_sphere(evdw2,evdw2_14)
4004 C
4005 C This subroutine calculates the excluded-volume interaction energy between
4006 C peptide-group centers and side chains and its gradient in virtual-bond and
4007 C side-chain vectors.
4008 C
4009       implicit real*8 (a-h,o-z)
4010       include 'DIMENSIONS'
4011       include 'COMMON.GEO'
4012       include 'COMMON.VAR'
4013       include 'COMMON.LOCAL'
4014       include 'COMMON.CHAIN'
4015       include 'COMMON.DERIV'
4016       include 'COMMON.INTERACT'
4017       include 'COMMON.FFIELD'
4018       include 'COMMON.IOUNITS'
4019       include 'COMMON.CONTROL'
4020       dimension ggg(3)
4021       evdw2=0.0D0
4022       evdw2_14=0.0d0
4023       r0_scp=4.5d0
4024 cd    print '(a)','Enter ESCP'
4025 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4026       do xshift=-1,1
4027       do yshift=-1,1
4028       do zshift=-1,1
4029       do i=iatscp_s,iatscp_e
4030         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4031         iteli=itel(i)
4032         xi=0.5D0*(c(1,i)+c(1,i+1))
4033         yi=0.5D0*(c(2,i)+c(2,i+1))
4034         zi=0.5D0*(c(3,i)+c(3,i+1))
4035 C Return atom into box, boxxsize is size of box in x dimension
4036   134   continue
4037         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4038         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4039 C Condition for being inside the proper box
4040         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4041      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4042         go to 134
4043         endif
4044   135   continue
4045         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4046         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4047 C Condition for being inside the proper box
4048         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4049      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4050         go to 135
4051         endif
4052   136   continue
4053         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxxsize
4054         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxxsize
4055 C Condition for being inside the proper box
4056         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4057      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4058         go to 136
4059         endif
4060         do iint=1,nscp_gr(i)
4061
4062         do j=iscpstart(i,iint),iscpend(i,iint)
4063           if (itype(j).eq.ntyp1) cycle
4064           itypj=iabs(itype(j))
4065 C Uncomment following three lines for SC-p interactions
4066 c         xj=c(1,nres+j)-xi
4067 c         yj=c(2,nres+j)-yi
4068 c         zj=c(3,nres+j)-zi
4069 C Uncomment following three lines for Ca-p interactions
4070           xj=c(1,j)
4071           yj=c(2,j)
4072           zj=c(3,j)
4073   174   continue
4074         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4075         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4076 C Condition for being inside the proper box
4077         if ((xj.gt.((0.5d0)*boxxsize)).or.
4078      &       (xj.lt.((-0.5d0)*boxxsize))) then
4079         go to 174
4080         endif
4081   175   continue
4082         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4083         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4084 C Condition for being inside the proper box
4085         if ((yj.gt.((0.5d0)*boxysize)).or.
4086      &       (yj.lt.((-0.5d0)*boxysize))) then
4087         go to 175
4088         endif
4089   176   continue
4090         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxxsize
4091         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxxsize
4092 C Condition for being inside the proper box
4093         if ((zj.gt.((0.5d0)*boxzsize)).or.
4094      &       (zj.lt.((-0.5d0)*boxzsize))) then
4095         go to 176
4096         endif
4097           xj=xj-xi
4098           yj=yj-yi
4099           zj=zj-zi
4100           rij=xj*xj+yj*yj+zj*zj
4101           r0ij=r0_scp
4102           r0ijsq=r0ij*r0ij
4103           if (rij.lt.r0ijsq) then
4104             evdwij=0.25d0*(rij-r0ijsq)**2
4105             fac=rij-r0ijsq
4106           else
4107             evdwij=0.0d0
4108             fac=0.0d0
4109           endif
4110           evdw2=evdw2+evdwij
4111 C
4112 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4113 C
4114           ggg(1)=xj*fac
4115           ggg(2)=yj*fac
4116           ggg(3)=zj*fac
4117 cgrad          if (j.lt.i) then
4118 cd          write (iout,*) 'j<i'
4119 C Uncomment following three lines for SC-p interactions
4120 c           do k=1,3
4121 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4122 c           enddo
4123 cgrad          else
4124 cd          write (iout,*) 'j>i'
4125 cgrad            do k=1,3
4126 cgrad              ggg(k)=-ggg(k)
4127 C Uncomment following line for SC-p interactions
4128 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4129 cgrad            enddo
4130 cgrad          endif
4131 cgrad          do k=1,3
4132 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4133 cgrad          enddo
4134 cgrad          kstart=min0(i+1,j)
4135 cgrad          kend=max0(i-1,j-1)
4136 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4137 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4138 cgrad          do k=kstart,kend
4139 cgrad            do l=1,3
4140 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4141 cgrad            enddo
4142 cgrad          enddo
4143           do k=1,3
4144             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4145             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4146           enddo
4147         enddo
4148
4149         enddo ! iint
4150       enddo ! i
4151       enddo !zshift
4152       enddo !yshift
4153       enddo !xshift
4154       return
4155       end
4156 C-----------------------------------------------------------------------------
4157       subroutine escp(evdw2,evdw2_14)
4158 C
4159 C This subroutine calculates the excluded-volume interaction energy between
4160 C peptide-group centers and side chains and its gradient in virtual-bond and
4161 C side-chain vectors.
4162 C
4163       implicit real*8 (a-h,o-z)
4164       include 'DIMENSIONS'
4165       include 'COMMON.GEO'
4166       include 'COMMON.VAR'
4167       include 'COMMON.LOCAL'
4168       include 'COMMON.CHAIN'
4169       include 'COMMON.DERIV'
4170       include 'COMMON.INTERACT'
4171       include 'COMMON.FFIELD'
4172       include 'COMMON.IOUNITS'
4173       include 'COMMON.CONTROL'
4174       dimension ggg(3)
4175       evdw2=0.0D0
4176       evdw2_14=0.0d0
4177 cd    print '(a)','Enter ESCP'
4178 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4179       do xshift=-1,1
4180       do yshift=-1,1
4181       do zshift=-1,1
4182       do i=iatscp_s,iatscp_e
4183         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4184         iteli=itel(i)
4185         xi=0.5D0*(c(1,i)+c(1,i+1))
4186         yi=0.5D0*(c(2,i)+c(2,i+1))
4187         zi=0.5D0*(c(3,i)+c(3,i+1))
4188 C Return atom into box, boxxsize is size of box in x dimension
4189   134   continue
4190         if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4191         if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4192 C Condition for being inside the proper box
4193         if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4194      &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4195         go to 134
4196         endif
4197   135   continue
4198         if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4199         if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4200 C Condition for being inside the proper box
4201         if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4202      &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4203         go to 135
4204         endif
4205   136   continue
4206         if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxxsize
4207         if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxxsize
4208 C Condition for being inside the proper box
4209         if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4210      &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4211         go to 136
4212         endif
4213         do iint=1,nscp_gr(i)
4214
4215         do j=iscpstart(i,iint),iscpend(i,iint)
4216           itypj=iabs(itype(j))
4217           if (itypj.eq.ntyp1) cycle
4218 C Uncomment following three lines for SC-p interactions
4219 c         xj=c(1,nres+j)-xi
4220 c         yj=c(2,nres+j)-yi
4221 c         zj=c(3,nres+j)-zi
4222 C Uncomment following three lines for Ca-p interactions
4223           xj=c(1,j)
4224           yj=c(2,j)
4225           zj=c(3,j)
4226   174   continue
4227         if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4228         if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4229 C Condition for being inside the proper box
4230         if ((xj.gt.((0.5d0)*boxxsize)).or.
4231      &       (xj.lt.((-0.5d0)*boxxsize))) then
4232         go to 174
4233         endif
4234   175   continue
4235         if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4236         if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4237 C Condition for being inside the proper box
4238         if ((yj.gt.((0.5d0)*boxysize)).or.
4239      &       (yj.lt.((-0.5d0)*boxysize))) then
4240         go to 175
4241         endif
4242   176   continue
4243         if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxxsize
4244         if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxxsize
4245 C Condition for being inside the proper box
4246         if ((zj.gt.((0.5d0)*boxzsize)).or.
4247      &       (zj.lt.((-0.5d0)*boxzsize))) then
4248         go to 176
4249         endif
4250           xj=xj-xi
4251           yj=yj-yi
4252           zj=zj-zi
4253           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4254           fac=rrij**expon2
4255           e1=fac*fac*aad(itypj,iteli)
4256           e2=fac*bad(itypj,iteli)
4257           if (iabs(j-i) .le. 2) then
4258             e1=scal14*e1
4259             e2=scal14*e2
4260             evdw2_14=evdw2_14+e1+e2
4261           endif
4262           evdwij=e1+e2
4263           evdw2=evdw2+evdwij
4264           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4265      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4266      &       bad(itypj,iteli)
4267 C
4268 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4269 C
4270           fac=-(evdwij+e1)*rrij
4271           ggg(1)=xj*fac
4272           ggg(2)=yj*fac
4273           ggg(3)=zj*fac
4274 cgrad          if (j.lt.i) then
4275 cd          write (iout,*) 'j<i'
4276 C Uncomment following three lines for SC-p interactions
4277 c           do k=1,3
4278 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4279 c           enddo
4280 cgrad          else
4281 cd          write (iout,*) 'j>i'
4282 cgrad            do k=1,3
4283 cgrad              ggg(k)=-ggg(k)
4284 C Uncomment following line for SC-p interactions
4285 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4286 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4287 cgrad            enddo
4288 cgrad          endif
4289 cgrad          do k=1,3
4290 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4291 cgrad          enddo
4292 cgrad          kstart=min0(i+1,j)
4293 cgrad          kend=max0(i-1,j-1)
4294 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4295 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4296 cgrad          do k=kstart,kend
4297 cgrad            do l=1,3
4298 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4299 cgrad            enddo
4300 cgrad          enddo
4301           do k=1,3
4302             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4303             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4304           enddo
4305         enddo
4306
4307         enddo ! iint
4308       enddo ! i
4309       enddo !zshift
4310       enddo !yshift
4311       enddo !xshift
4312       do i=1,nct
4313         do j=1,3
4314           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4315           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4316           gradx_scp(j,i)=expon*gradx_scp(j,i)
4317         enddo
4318       enddo
4319 C******************************************************************************
4320 C
4321 C                              N O T E !!!
4322 C
4323 C To save time the factor EXPON has been extracted from ALL components
4324 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4325 C use!
4326 C
4327 C******************************************************************************
4328       return
4329       end
4330 C--------------------------------------------------------------------------
4331       subroutine edis(ehpb)
4332 C
4333 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4334 C
4335       implicit real*8 (a-h,o-z)
4336       include 'DIMENSIONS'
4337       include 'COMMON.SBRIDGE'
4338       include 'COMMON.CHAIN'
4339       include 'COMMON.DERIV'
4340       include 'COMMON.VAR'
4341       include 'COMMON.INTERACT'
4342       include 'COMMON.IOUNITS'
4343       dimension ggg(3)
4344       ehpb=0.0D0
4345 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4346 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4347       if (link_end.eq.0) return
4348       do i=link_start,link_end
4349 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4350 C CA-CA distance used in regularization of structure.
4351         ii=ihpb(i)
4352         jj=jhpb(i)
4353 C iii and jjj point to the residues for which the distance is assigned.
4354         if (ii.gt.nres) then
4355           iii=ii-nres
4356           jjj=jj-nres
4357         else
4358           iii=ii
4359           jjj=jj
4360         endif
4361 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4362 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4363 C    distance and angle dependent SS bond potential.
4364         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4365      & iabs(itype(jjj)).eq.1) then
4366           call ssbond_ene(iii,jjj,eij)
4367           ehpb=ehpb+2*eij
4368 cd          write (iout,*) "eij",eij
4369         else
4370 C Calculate the distance between the two points and its difference from the
4371 C target distance.
4372         dd=dist(ii,jj)
4373         rdis=dd-dhpb(i)
4374 C Get the force constant corresponding to this distance.
4375         waga=forcon(i)
4376 C Calculate the contribution to energy.
4377         ehpb=ehpb+waga*rdis*rdis
4378 C
4379 C Evaluate gradient.
4380 C
4381         fac=waga*rdis/dd
4382 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4383 cd   &   ' waga=',waga,' fac=',fac
4384         do j=1,3
4385           ggg(j)=fac*(c(j,jj)-c(j,ii))
4386         enddo
4387 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4388 C If this is a SC-SC distance, we need to calculate the contributions to the
4389 C Cartesian gradient in the SC vectors (ghpbx).
4390         if (iii.lt.ii) then
4391           do j=1,3
4392             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4393             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4394           enddo
4395         endif
4396 cgrad        do j=iii,jjj-1
4397 cgrad          do k=1,3
4398 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4399 cgrad          enddo
4400 cgrad        enddo
4401         do k=1,3
4402           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4403           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4404         enddo
4405         endif
4406       enddo
4407       ehpb=0.5D0*ehpb
4408       return
4409       end
4410 C--------------------------------------------------------------------------
4411       subroutine ssbond_ene(i,j,eij)
4412 C
4413 C Calculate the distance and angle dependent SS-bond potential energy
4414 C using a free-energy function derived based on RHF/6-31G** ab initio
4415 C calculations of diethyl disulfide.
4416 C
4417 C A. Liwo and U. Kozlowska, 11/24/03
4418 C
4419       implicit real*8 (a-h,o-z)
4420       include 'DIMENSIONS'
4421       include 'COMMON.SBRIDGE'
4422       include 'COMMON.CHAIN'
4423       include 'COMMON.DERIV'
4424       include 'COMMON.LOCAL'
4425       include 'COMMON.INTERACT'
4426       include 'COMMON.VAR'
4427       include 'COMMON.IOUNITS'
4428       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4429       itypi=iabs(itype(i))
4430       xi=c(1,nres+i)
4431       yi=c(2,nres+i)
4432       zi=c(3,nres+i)
4433       dxi=dc_norm(1,nres+i)
4434       dyi=dc_norm(2,nres+i)
4435       dzi=dc_norm(3,nres+i)
4436 c      dsci_inv=dsc_inv(itypi)
4437       dsci_inv=vbld_inv(nres+i)
4438       itypj=iabs(itype(j))
4439 c      dscj_inv=dsc_inv(itypj)
4440       dscj_inv=vbld_inv(nres+j)
4441       xj=c(1,nres+j)-xi
4442       yj=c(2,nres+j)-yi
4443       zj=c(3,nres+j)-zi
4444       dxj=dc_norm(1,nres+j)
4445       dyj=dc_norm(2,nres+j)
4446       dzj=dc_norm(3,nres+j)
4447       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4448       rij=dsqrt(rrij)
4449       erij(1)=xj*rij
4450       erij(2)=yj*rij
4451       erij(3)=zj*rij
4452       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4453       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4454       om12=dxi*dxj+dyi*dyj+dzi*dzj
4455       do k=1,3
4456         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4457         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4458       enddo
4459       rij=1.0d0/rij
4460       deltad=rij-d0cm
4461       deltat1=1.0d0-om1
4462       deltat2=1.0d0+om2
4463       deltat12=om2-om1+2.0d0
4464       cosphi=om12-om1*om2
4465       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4466      &  +akct*deltad*deltat12
4467      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4468 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4469 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4470 c     &  " deltat12",deltat12," eij",eij
4471       ed=2*akcm*deltad+akct*deltat12
4472       pom1=akct*deltad
4473       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4474       eom1=-2*akth*deltat1-pom1-om2*pom2
4475       eom2= 2*akth*deltat2+pom1-om1*pom2
4476       eom12=pom2
4477       do k=1,3
4478         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4479         ghpbx(k,i)=ghpbx(k,i)-ggk
4480      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4481      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4482         ghpbx(k,j)=ghpbx(k,j)+ggk
4483      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4484      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4485         ghpbc(k,i)=ghpbc(k,i)-ggk
4486         ghpbc(k,j)=ghpbc(k,j)+ggk
4487       enddo
4488 C
4489 C Calculate the components of the gradient in DC and X
4490 C
4491 cgrad      do k=i,j-1
4492 cgrad        do l=1,3
4493 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4494 cgrad        enddo
4495 cgrad      enddo
4496       return
4497       end
4498 C--------------------------------------------------------------------------
4499       subroutine ebond(estr)
4500 c
4501 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4502 c
4503       implicit real*8 (a-h,o-z)
4504       include 'DIMENSIONS'
4505       include 'COMMON.LOCAL'
4506       include 'COMMON.GEO'
4507       include 'COMMON.INTERACT'
4508       include 'COMMON.DERIV'
4509       include 'COMMON.VAR'
4510       include 'COMMON.CHAIN'
4511       include 'COMMON.IOUNITS'
4512       include 'COMMON.NAMES'
4513       include 'COMMON.FFIELD'
4514       include 'COMMON.CONTROL'
4515       include 'COMMON.SETUP'
4516       double precision u(3),ud(3)
4517       estr=0.0d0
4518       estr1=0.0d0
4519       do i=ibondp_start,ibondp_end
4520         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4521 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4522 c          do j=1,3
4523 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4524 c     &      *dc(j,i-1)/vbld(i)
4525 c          enddo
4526 c          if (energy_dec) write(iout,*)
4527 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4528 c        else
4529 C       Checking if it involves dummy (NH3+ or COO-) group
4530          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4531 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4532         diff = vbld(i)-vbldpDUM
4533          else
4534 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4535         diff = vbld(i)-vbldp0
4536          endif
4537         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4538      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4539         estr=estr+diff*diff
4540         do j=1,3
4541           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4542         enddo
4543 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4544 c        endif
4545       enddo
4546       estr=0.5d0*AKP*estr+estr1
4547 c
4548 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4549 c
4550       do i=ibond_start,ibond_end
4551         iti=iabs(itype(i))
4552         if (iti.ne.10 .and. iti.ne.ntyp1) then
4553           nbi=nbondterm(iti)
4554           if (nbi.eq.1) then
4555             diff=vbld(i+nres)-vbldsc0(1,iti)
4556             if (energy_dec) write (iout,*)
4557      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4558      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4559             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4560             do j=1,3
4561               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4562             enddo
4563           else
4564             do j=1,nbi
4565               diff=vbld(i+nres)-vbldsc0(j,iti)
4566               ud(j)=aksc(j,iti)*diff
4567               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4568             enddo
4569             uprod=u(1)
4570             do j=2,nbi
4571               uprod=uprod*u(j)
4572             enddo
4573             usum=0.0d0
4574             usumsqder=0.0d0
4575             do j=1,nbi
4576               uprod1=1.0d0
4577               uprod2=1.0d0
4578               do k=1,nbi
4579                 if (k.ne.j) then
4580                   uprod1=uprod1*u(k)
4581                   uprod2=uprod2*u(k)*u(k)
4582                 endif
4583               enddo
4584               usum=usum+uprod1
4585               usumsqder=usumsqder+ud(j)*uprod2
4586             enddo
4587             estr=estr+uprod/usum
4588             do j=1,3
4589              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4590             enddo
4591           endif
4592         endif
4593       enddo
4594       return
4595       end
4596 #ifdef CRYST_THETA
4597 C--------------------------------------------------------------------------
4598       subroutine ebend(etheta)
4599 C
4600 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4601 C angles gamma and its derivatives in consecutive thetas and gammas.
4602 C
4603       implicit real*8 (a-h,o-z)
4604       include 'DIMENSIONS'
4605       include 'COMMON.LOCAL'
4606       include 'COMMON.GEO'
4607       include 'COMMON.INTERACT'
4608       include 'COMMON.DERIV'
4609       include 'COMMON.VAR'
4610       include 'COMMON.CHAIN'
4611       include 'COMMON.IOUNITS'
4612       include 'COMMON.NAMES'
4613       include 'COMMON.FFIELD'
4614       include 'COMMON.CONTROL'
4615       common /calcthet/ term1,term2,termm,diffak,ratak,
4616      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4617      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4618       double precision y(2),z(2)
4619       delta=0.02d0*pi
4620 c      time11=dexp(-2*time)
4621 c      time12=1.0d0
4622       etheta=0.0D0
4623 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4624       do i=ithet_start,ithet_end
4625         if (itype(i-1).eq.ntyp1) cycle
4626 C Zero the energy function and its derivative at 0 or pi.
4627         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4628         it=itype(i-1)
4629         ichir1=isign(1,itype(i-2))
4630         ichir2=isign(1,itype(i))
4631          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4632          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4633          if (itype(i-1).eq.10) then
4634           itype1=isign(10,itype(i-2))
4635           ichir11=isign(1,itype(i-2))
4636           ichir12=isign(1,itype(i-2))
4637           itype2=isign(10,itype(i))
4638           ichir21=isign(1,itype(i))
4639           ichir22=isign(1,itype(i))
4640          endif
4641
4642         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4643 #ifdef OSF
4644           phii=phi(i)
4645           if (phii.ne.phii) phii=150.0
4646 #else
4647           phii=phi(i)
4648 #endif
4649           y(1)=dcos(phii)
4650           y(2)=dsin(phii)
4651         else
4652           y(1)=0.0D0
4653           y(2)=0.0D0
4654         endif
4655         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4656 #ifdef OSF
4657           phii1=phi(i+1)
4658           if (phii1.ne.phii1) phii1=150.0
4659           phii1=pinorm(phii1)
4660           z(1)=cos(phii1)
4661 #else
4662           phii1=phi(i+1)
4663           z(1)=dcos(phii1)
4664 #endif
4665           z(2)=dsin(phii1)
4666         else
4667           z(1)=0.0D0
4668           z(2)=0.0D0
4669         endif
4670 C Calculate the "mean" value of theta from the part of the distribution
4671 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4672 C In following comments this theta will be referred to as t_c.
4673         thet_pred_mean=0.0d0
4674         do k=1,2
4675             athetk=athet(k,it,ichir1,ichir2)
4676             bthetk=bthet(k,it,ichir1,ichir2)
4677           if (it.eq.10) then
4678              athetk=athet(k,itype1,ichir11,ichir12)
4679              bthetk=bthet(k,itype2,ichir21,ichir22)
4680           endif
4681          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4682 c         write(iout,*) 'chuj tu', y(k),z(k)
4683         enddo
4684         dthett=thet_pred_mean*ssd
4685         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4686 C Derivatives of the "mean" values in gamma1 and gamma2.
4687         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4688      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4689          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4690      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4691          if (it.eq.10) then
4692       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4693      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4694         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4695      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4696          endif
4697         if (theta(i).gt.pi-delta) then
4698           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4699      &         E_tc0)
4700           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4701           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4702           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4703      &        E_theta)
4704           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4705      &        E_tc)
4706         else if (theta(i).lt.delta) then
4707           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4708           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4709           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4710      &        E_theta)
4711           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4712           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4713      &        E_tc)
4714         else
4715           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4716      &        E_theta,E_tc)
4717         endif
4718         etheta=etheta+ethetai
4719         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4720      &      'ebend',i,ethetai,theta(i),itype(i)
4721         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4722         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4723         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4724       enddo
4725 C Ufff.... We've done all this!!!
4726       return
4727       end
4728 C---------------------------------------------------------------------------
4729       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4730      &     E_tc)
4731       implicit real*8 (a-h,o-z)
4732       include 'DIMENSIONS'
4733       include 'COMMON.LOCAL'
4734       include 'COMMON.IOUNITS'
4735       common /calcthet/ term1,term2,termm,diffak,ratak,
4736      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4737      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4738 C Calculate the contributions to both Gaussian lobes.
4739 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4740 C The "polynomial part" of the "standard deviation" of this part of
4741 C the distributioni.
4742         write (iout,*) thetai,thet_pred_mean
4743         sig=polthet(3,it)
4744         do j=2,0,-1
4745           sig=sig*thet_pred_mean+polthet(j,it)
4746         enddo
4747 C Derivative of the "interior part" of the "standard deviation of the"
4748 C gamma-dependent Gaussian lobe in t_c.
4749         sigtc=3*polthet(3,it)
4750         do j=2,1,-1
4751           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4752         enddo
4753         sigtc=sig*sigtc
4754 C Set the parameters of both Gaussian lobes of the distribution.
4755 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4756         fac=sig*sig+sigc0(it)
4757         sigcsq=fac+fac
4758         sigc=1.0D0/sigcsq
4759 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4760         sigsqtc=-4.0D0*sigcsq*sigtc
4761 c       print *,i,sig,sigtc,sigsqtc
4762 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4763         sigtc=-sigtc/(fac*fac)
4764 C Following variable is sigma(t_c)**(-2)
4765         sigcsq=sigcsq*sigcsq
4766         sig0i=sig0(it)
4767         sig0inv=1.0D0/sig0i**2
4768         delthec=thetai-thet_pred_mean
4769         delthe0=thetai-theta0i
4770         term1=-0.5D0*sigcsq*delthec*delthec
4771         term2=-0.5D0*sig0inv*delthe0*delthe0
4772 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
4773 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4774 C NaNs in taking the logarithm. We extract the largest exponent which is added
4775 C to the energy (this being the log of the distribution) at the end of energy
4776 C term evaluation for this virtual-bond angle.
4777         if (term1.gt.term2) then
4778           termm=term1
4779           term2=dexp(term2-termm)
4780           term1=1.0d0
4781         else
4782           termm=term2
4783           term1=dexp(term1-termm)
4784           term2=1.0d0
4785         endif
4786 C The ratio between the gamma-independent and gamma-dependent lobes of
4787 C the distribution is a Gaussian function of thet_pred_mean too.
4788         diffak=gthet(2,it)-thet_pred_mean
4789         ratak=diffak/gthet(3,it)**2
4790         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4791 C Let's differentiate it in thet_pred_mean NOW.
4792         aktc=ak*ratak
4793 C Now put together the distribution terms to make complete distribution.
4794         termexp=term1+ak*term2
4795         termpre=sigc+ak*sig0i
4796 C Contribution of the bending energy from this theta is just the -log of
4797 C the sum of the contributions from the two lobes and the pre-exponential
4798 C factor. Simple enough, isn't it?
4799         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4800 C       write (iout,*) 'termexp',termexp,termm,termpre,i
4801 C NOW the derivatives!!!
4802 C 6/6/97 Take into account the deformation.
4803         E_theta=(delthec*sigcsq*term1
4804      &       +ak*delthe0*sig0inv*term2)/termexp
4805         E_tc=((sigtc+aktc*sig0i)/termpre
4806      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4807      &       aktc*term2)/termexp)
4808       return
4809       end
4810 c-----------------------------------------------------------------------------
4811       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4812       implicit real*8 (a-h,o-z)
4813       include 'DIMENSIONS'
4814       include 'COMMON.LOCAL'
4815       include 'COMMON.IOUNITS'
4816       common /calcthet/ term1,term2,termm,diffak,ratak,
4817      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4818      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4819       delthec=thetai-thet_pred_mean
4820       delthe0=thetai-theta0i
4821 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4822       t3 = thetai-thet_pred_mean
4823       t6 = t3**2
4824       t9 = term1
4825       t12 = t3*sigcsq
4826       t14 = t12+t6*sigsqtc
4827       t16 = 1.0d0
4828       t21 = thetai-theta0i
4829       t23 = t21**2
4830       t26 = term2
4831       t27 = t21*t26
4832       t32 = termexp
4833       t40 = t32**2
4834       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4835      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4836      & *(-t12*t9-ak*sig0inv*t27)
4837       return
4838       end
4839 #else
4840 C--------------------------------------------------------------------------
4841       subroutine ebend(etheta)
4842 C
4843 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4844 C angles gamma and its derivatives in consecutive thetas and gammas.
4845 C ab initio-derived potentials from
4846 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4847 C
4848       implicit real*8 (a-h,o-z)
4849       include 'DIMENSIONS'
4850       include 'COMMON.LOCAL'
4851       include 'COMMON.GEO'
4852       include 'COMMON.INTERACT'
4853       include 'COMMON.DERIV'
4854       include 'COMMON.VAR'
4855       include 'COMMON.CHAIN'
4856       include 'COMMON.IOUNITS'
4857       include 'COMMON.NAMES'
4858       include 'COMMON.FFIELD'
4859       include 'COMMON.CONTROL'
4860       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4861      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4862      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4863      & sinph1ph2(maxdouble,maxdouble)
4864       logical lprn /.false./, lprn1 /.false./
4865       etheta=0.0D0
4866       do i=ithet_start,ithet_end
4867         if ((itype(i-1).eq.ntyp1)) cycle
4868         if (iabs(itype(i+1)).eq.20) iblock=2
4869         if (iabs(itype(i+1)).ne.20) iblock=1
4870         dethetai=0.0d0
4871         dephii=0.0d0
4872         dephii1=0.0d0
4873         theti2=0.5d0*theta(i)
4874         ityp2=ithetyp((itype(i-1)))
4875         do k=1,nntheterm
4876           coskt(k)=dcos(k*theti2)
4877           sinkt(k)=dsin(k*theti2)
4878         enddo
4879         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4880 #ifdef OSF
4881           phii=phi(i)
4882           if (phii.ne.phii) phii=150.0
4883 #else
4884           phii=phi(i)
4885 #endif
4886           ityp1=ithetyp((itype(i-2)))
4887 C propagation of chirality for glycine type
4888           do k=1,nsingle
4889             cosph1(k)=dcos(k*phii)
4890             sinph1(k)=dsin(k*phii)
4891           enddo
4892         else
4893           phii=0.0d0
4894           ityp1=nthetyp+1
4895           do k=1,nsingle
4896             cosph1(k)=0.0d0
4897             sinph1(k)=0.0d0
4898           enddo
4899         endif
4900         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4901 #ifdef OSF
4902           phii1=phi(i+1)
4903           if (phii1.ne.phii1) phii1=150.0
4904           phii1=pinorm(phii1)
4905 #else
4906           phii1=phi(i+1)
4907 #endif
4908           ityp3=ithetyp((itype(i)))
4909           do k=1,nsingle
4910             cosph2(k)=dcos(k*phii1)
4911             sinph2(k)=dsin(k*phii1)
4912           enddo
4913         else
4914           phii1=0.0d0
4915           ityp3=nthetyp+1
4916           do k=1,nsingle
4917             cosph2(k)=0.0d0
4918             sinph2(k)=0.0d0
4919           enddo
4920         endif
4921         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4922         do k=1,ndouble
4923           do l=1,k-1
4924             ccl=cosph1(l)*cosph2(k-l)
4925             ssl=sinph1(l)*sinph2(k-l)
4926             scl=sinph1(l)*cosph2(k-l)
4927             csl=cosph1(l)*sinph2(k-l)
4928             cosph1ph2(l,k)=ccl-ssl
4929             cosph1ph2(k,l)=ccl+ssl
4930             sinph1ph2(l,k)=scl+csl
4931             sinph1ph2(k,l)=scl-csl
4932           enddo
4933         enddo
4934         if (lprn) then
4935         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4936      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4937         write (iout,*) "coskt and sinkt"
4938         do k=1,nntheterm
4939           write (iout,*) k,coskt(k),sinkt(k)
4940         enddo
4941         endif
4942         do k=1,ntheterm
4943           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4944           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4945      &      *coskt(k)
4946           if (lprn)
4947      &    write (iout,*) "k",k,"
4948      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4949      &     " ethetai",ethetai
4950         enddo
4951         if (lprn) then
4952         write (iout,*) "cosph and sinph"
4953         do k=1,nsingle
4954           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4955         enddo
4956         write (iout,*) "cosph1ph2 and sinph2ph2"
4957         do k=2,ndouble
4958           do l=1,k-1
4959             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4960      &         sinph1ph2(l,k),sinph1ph2(k,l)
4961           enddo
4962         enddo
4963         write(iout,*) "ethetai",ethetai
4964         endif
4965         do m=1,ntheterm2
4966           do k=1,nsingle
4967             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4968      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4969      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4970      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4971             ethetai=ethetai+sinkt(m)*aux
4972             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4973             dephii=dephii+k*sinkt(m)*(
4974      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4975      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4976             dephii1=dephii1+k*sinkt(m)*(
4977      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4978      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4979             if (lprn)
4980      &      write (iout,*) "m",m," k",k," bbthet",
4981      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4982      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4983      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4984      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4985           enddo
4986         enddo
4987         if (lprn)
4988      &  write(iout,*) "ethetai",ethetai
4989         do m=1,ntheterm3
4990           do k=2,ndouble
4991             do l=1,k-1
4992               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4993      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4994      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4995      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4996               ethetai=ethetai+sinkt(m)*aux
4997               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4998               dephii=dephii+l*sinkt(m)*(
4999      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5000      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5001      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5002      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5003               dephii1=dephii1+(k-l)*sinkt(m)*(
5004      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5005      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5006      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5007      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5008               if (lprn) then
5009               write (iout,*) "m",m," k",k," l",l," ffthet",
5010      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5011      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5012      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5013      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5014      &            " ethetai",ethetai
5015               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5016      &            cosph1ph2(k,l)*sinkt(m),
5017      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5018               endif
5019             enddo
5020           enddo
5021         enddo
5022 10      continue
5023 c        lprn1=.true.
5024         if (lprn1)
5025      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5026      &   i,theta(i)*rad2deg,phii*rad2deg,
5027      &   phii1*rad2deg,ethetai
5028 c        lprn1=.false.
5029         etheta=etheta+ethetai
5030         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5031         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5032         gloc(nphi+i-2,icg)=wang*dethetai
5033       enddo
5034       return
5035       end
5036 #endif
5037 #ifdef CRYST_SC
5038 c-----------------------------------------------------------------------------
5039       subroutine esc(escloc)
5040 C Calculate the local energy of a side chain and its derivatives in the
5041 C corresponding virtual-bond valence angles THETA and the spherical angles
5042 C ALPHA and OMEGA.
5043       implicit real*8 (a-h,o-z)
5044       include 'DIMENSIONS'
5045       include 'COMMON.GEO'
5046       include 'COMMON.LOCAL'
5047       include 'COMMON.VAR'
5048       include 'COMMON.INTERACT'
5049       include 'COMMON.DERIV'
5050       include 'COMMON.CHAIN'
5051       include 'COMMON.IOUNITS'
5052       include 'COMMON.NAMES'
5053       include 'COMMON.FFIELD'
5054       include 'COMMON.CONTROL'
5055       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5056      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5057       common /sccalc/ time11,time12,time112,theti,it,nlobit
5058       delta=0.02d0*pi
5059       escloc=0.0D0
5060 c     write (iout,'(a)') 'ESC'
5061       do i=loc_start,loc_end
5062         it=itype(i)
5063         if (it.eq.ntyp1) cycle
5064         if (it.eq.10) goto 1
5065         nlobit=nlob(iabs(it))
5066 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5067 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5068         theti=theta(i+1)-pipol
5069         x(1)=dtan(theti)
5070         x(2)=alph(i)
5071         x(3)=omeg(i)
5072
5073         if (x(2).gt.pi-delta) then
5074           xtemp(1)=x(1)
5075           xtemp(2)=pi-delta
5076           xtemp(3)=x(3)
5077           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5078           xtemp(2)=pi
5079           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5080           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5081      &        escloci,dersc(2))
5082           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5083      &        ddersc0(1),dersc(1))
5084           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5085      &        ddersc0(3),dersc(3))
5086           xtemp(2)=pi-delta
5087           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5088           xtemp(2)=pi
5089           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5090           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5091      &            dersc0(2),esclocbi,dersc02)
5092           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5093      &            dersc12,dersc01)
5094           call splinthet(x(2),0.5d0*delta,ss,ssd)
5095           dersc0(1)=dersc01
5096           dersc0(2)=dersc02
5097           dersc0(3)=0.0d0
5098           do k=1,3
5099             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5100           enddo
5101           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5102 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5103 c    &             esclocbi,ss,ssd
5104           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5105 c         escloci=esclocbi
5106 c         write (iout,*) escloci
5107         else if (x(2).lt.delta) then
5108           xtemp(1)=x(1)
5109           xtemp(2)=delta
5110           xtemp(3)=x(3)
5111           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5112           xtemp(2)=0.0d0
5113           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5114           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5115      &        escloci,dersc(2))
5116           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5117      &        ddersc0(1),dersc(1))
5118           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5119      &        ddersc0(3),dersc(3))
5120           xtemp(2)=delta
5121           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5122           xtemp(2)=0.0d0
5123           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5124           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5125      &            dersc0(2),esclocbi,dersc02)
5126           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5127      &            dersc12,dersc01)
5128           dersc0(1)=dersc01
5129           dersc0(2)=dersc02
5130           dersc0(3)=0.0d0
5131           call splinthet(x(2),0.5d0*delta,ss,ssd)
5132           do k=1,3
5133             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5134           enddo
5135           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5136 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5137 c    &             esclocbi,ss,ssd
5138           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5139 c         write (iout,*) escloci
5140         else
5141           call enesc(x,escloci,dersc,ddummy,.false.)
5142         endif
5143
5144         escloc=escloc+escloci
5145         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5146      &     'escloc',i,escloci
5147 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5148
5149         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5150      &   wscloc*dersc(1)
5151         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5152         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5153     1   continue
5154       enddo
5155       return
5156       end
5157 C---------------------------------------------------------------------------
5158       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5159       implicit real*8 (a-h,o-z)
5160       include 'DIMENSIONS'
5161       include 'COMMON.GEO'
5162       include 'COMMON.LOCAL'
5163       include 'COMMON.IOUNITS'
5164       common /sccalc/ time11,time12,time112,theti,it,nlobit
5165       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5166       double precision contr(maxlob,-1:1)
5167       logical mixed
5168 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5169         escloc_i=0.0D0
5170         do j=1,3
5171           dersc(j)=0.0D0
5172           if (mixed) ddersc(j)=0.0d0
5173         enddo
5174         x3=x(3)
5175
5176 C Because of periodicity of the dependence of the SC energy in omega we have
5177 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5178 C To avoid underflows, first compute & store the exponents.
5179
5180         do iii=-1,1
5181
5182           x(3)=x3+iii*dwapi
5183
5184           do j=1,nlobit
5185             do k=1,3
5186               z(k)=x(k)-censc(k,j,it)
5187             enddo
5188             do k=1,3
5189               Axk=0.0D0
5190               do l=1,3
5191                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5192               enddo
5193               Ax(k,j,iii)=Axk
5194             enddo
5195             expfac=0.0D0
5196             do k=1,3
5197               expfac=expfac+Ax(k,j,iii)*z(k)
5198             enddo
5199             contr(j,iii)=expfac
5200           enddo ! j
5201
5202         enddo ! iii
5203
5204         x(3)=x3
5205 C As in the case of ebend, we want to avoid underflows in exponentiation and
5206 C subsequent NaNs and INFs in energy calculation.
5207 C Find the largest exponent
5208         emin=contr(1,-1)
5209         do iii=-1,1
5210           do j=1,nlobit
5211             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5212           enddo
5213         enddo
5214         emin=0.5D0*emin
5215 cd      print *,'it=',it,' emin=',emin
5216
5217 C Compute the contribution to SC energy and derivatives
5218         do iii=-1,1
5219
5220           do j=1,nlobit
5221 #ifdef OSF
5222             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5223             if(adexp.ne.adexp) adexp=1.0
5224             expfac=dexp(adexp)
5225 #else
5226             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5227 #endif
5228 cd          print *,'j=',j,' expfac=',expfac
5229             escloc_i=escloc_i+expfac
5230             do k=1,3
5231               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5232             enddo
5233             if (mixed) then
5234               do k=1,3,2
5235                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5236      &            +gaussc(k,2,j,it))*expfac
5237               enddo
5238             endif
5239           enddo
5240
5241         enddo ! iii
5242
5243         dersc(1)=dersc(1)/cos(theti)**2
5244         ddersc(1)=ddersc(1)/cos(theti)**2
5245         ddersc(3)=ddersc(3)
5246
5247         escloci=-(dlog(escloc_i)-emin)
5248         do j=1,3
5249           dersc(j)=dersc(j)/escloc_i
5250         enddo
5251         if (mixed) then
5252           do j=1,3,2
5253             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5254           enddo
5255         endif
5256       return
5257       end
5258 C------------------------------------------------------------------------------
5259       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5260       implicit real*8 (a-h,o-z)
5261       include 'DIMENSIONS'
5262       include 'COMMON.GEO'
5263       include 'COMMON.LOCAL'
5264       include 'COMMON.IOUNITS'
5265       common /sccalc/ time11,time12,time112,theti,it,nlobit
5266       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5267       double precision contr(maxlob)
5268       logical mixed
5269
5270       escloc_i=0.0D0
5271
5272       do j=1,3
5273         dersc(j)=0.0D0
5274       enddo
5275
5276       do j=1,nlobit
5277         do k=1,2
5278           z(k)=x(k)-censc(k,j,it)
5279         enddo
5280         z(3)=dwapi
5281         do k=1,3
5282           Axk=0.0D0
5283           do l=1,3
5284             Axk=Axk+gaussc(l,k,j,it)*z(l)
5285           enddo
5286           Ax(k,j)=Axk
5287         enddo
5288         expfac=0.0D0
5289         do k=1,3
5290           expfac=expfac+Ax(k,j)*z(k)
5291         enddo
5292         contr(j)=expfac
5293       enddo ! j
5294
5295 C As in the case of ebend, we want to avoid underflows in exponentiation and
5296 C subsequent NaNs and INFs in energy calculation.
5297 C Find the largest exponent
5298       emin=contr(1)
5299       do j=1,nlobit
5300         if (emin.gt.contr(j)) emin=contr(j)
5301       enddo
5302       emin=0.5D0*emin
5303
5304 C Compute the contribution to SC energy and derivatives
5305
5306       dersc12=0.0d0
5307       do j=1,nlobit
5308         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5309         escloc_i=escloc_i+expfac
5310         do k=1,2
5311           dersc(k)=dersc(k)+Ax(k,j)*expfac
5312         enddo
5313         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5314      &            +gaussc(1,2,j,it))*expfac
5315         dersc(3)=0.0d0
5316       enddo
5317
5318       dersc(1)=dersc(1)/cos(theti)**2
5319       dersc12=dersc12/cos(theti)**2
5320       escloci=-(dlog(escloc_i)-emin)
5321       do j=1,2
5322         dersc(j)=dersc(j)/escloc_i
5323       enddo
5324       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5325       return
5326       end
5327 #else
5328 c----------------------------------------------------------------------------------
5329       subroutine esc(escloc)
5330 C Calculate the local energy of a side chain and its derivatives in the
5331 C corresponding virtual-bond valence angles THETA and the spherical angles
5332 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5333 C added by Urszula Kozlowska. 07/11/2007
5334 C
5335       implicit real*8 (a-h,o-z)
5336       include 'DIMENSIONS'
5337       include 'COMMON.GEO'
5338       include 'COMMON.LOCAL'
5339       include 'COMMON.VAR'
5340       include 'COMMON.SCROT'
5341       include 'COMMON.INTERACT'
5342       include 'COMMON.DERIV'
5343       include 'COMMON.CHAIN'
5344       include 'COMMON.IOUNITS'
5345       include 'COMMON.NAMES'
5346       include 'COMMON.FFIELD'
5347       include 'COMMON.CONTROL'
5348       include 'COMMON.VECTORS'
5349       double precision x_prime(3),y_prime(3),z_prime(3)
5350      &    , sumene,dsc_i,dp2_i,x(65),
5351      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5352      &    de_dxx,de_dyy,de_dzz,de_dt
5353       double precision s1_t,s1_6_t,s2_t,s2_6_t
5354       double precision
5355      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5356      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5357      & dt_dCi(3),dt_dCi1(3)
5358       common /sccalc/ time11,time12,time112,theti,it,nlobit
5359       delta=0.02d0*pi
5360       escloc=0.0D0
5361       do i=loc_start,loc_end
5362         if (itype(i).eq.ntyp1) cycle
5363         costtab(i+1) =dcos(theta(i+1))
5364         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5365         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5366         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5367         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5368         cosfac=dsqrt(cosfac2)
5369         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5370         sinfac=dsqrt(sinfac2)
5371         it=iabs(itype(i))
5372         if (it.eq.10) goto 1
5373 c
5374 C  Compute the axes of tghe local cartesian coordinates system; store in
5375 c   x_prime, y_prime and z_prime
5376 c
5377         do j=1,3
5378           x_prime(j) = 0.00
5379           y_prime(j) = 0.00
5380           z_prime(j) = 0.00
5381         enddo
5382 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5383 C     &   dc_norm(3,i+nres)
5384         do j = 1,3
5385           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5386           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5387         enddo
5388         do j = 1,3
5389           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5390         enddo
5391 c       write (2,*) "i",i
5392 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5393 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5394 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5395 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5396 c      & " xy",scalar(x_prime(1),y_prime(1)),
5397 c      & " xz",scalar(x_prime(1),z_prime(1)),
5398 c      & " yy",scalar(y_prime(1),y_prime(1)),
5399 c      & " yz",scalar(y_prime(1),z_prime(1)),
5400 c      & " zz",scalar(z_prime(1),z_prime(1))
5401 c
5402 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5403 C to local coordinate system. Store in xx, yy, zz.
5404 c
5405         xx=0.0d0
5406         yy=0.0d0
5407         zz=0.0d0
5408         do j = 1,3
5409           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5410           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5411           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5412         enddo
5413
5414         xxtab(i)=xx
5415         yytab(i)=yy
5416         zztab(i)=zz
5417 C
5418 C Compute the energy of the ith side cbain
5419 C
5420 c        write (2,*) "xx",xx," yy",yy," zz",zz
5421         it=iabs(itype(i))
5422         do j = 1,65
5423           x(j) = sc_parmin(j,it)
5424         enddo
5425 #ifdef CHECK_COORD
5426 Cc diagnostics - remove later
5427         xx1 = dcos(alph(2))
5428         yy1 = dsin(alph(2))*dcos(omeg(2))
5429         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5430         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5431      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5432      &    xx1,yy1,zz1
5433 C,"  --- ", xx_w,yy_w,zz_w
5434 c end diagnostics
5435 #endif
5436         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5437      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5438      &   + x(10)*yy*zz
5439         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5440      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5441      & + x(20)*yy*zz
5442         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5443      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5444      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5445      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5446      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5447      &  +x(40)*xx*yy*zz
5448         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5449      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5450      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5451      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5452      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5453      &  +x(60)*xx*yy*zz
5454         dsc_i   = 0.743d0+x(61)
5455         dp2_i   = 1.9d0+x(62)
5456         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5457      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5458         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5459      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5460         s1=(1+x(63))/(0.1d0 + dscp1)
5461         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5462         s2=(1+x(65))/(0.1d0 + dscp2)
5463         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5464         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5465      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5466 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5467 c     &   sumene4,
5468 c     &   dscp1,dscp2,sumene
5469 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5470         escloc = escloc + sumene
5471 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5472 c     & ,zz,xx,yy
5473 c#define DEBUG
5474 #ifdef DEBUG
5475 C
5476 C This section to check the numerical derivatives of the energy of ith side
5477 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5478 C #define DEBUG in the code to turn it on.
5479 C
5480         write (2,*) "sumene               =",sumene
5481         aincr=1.0d-7
5482         xxsave=xx
5483         xx=xx+aincr
5484         write (2,*) xx,yy,zz
5485         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5486         de_dxx_num=(sumenep-sumene)/aincr
5487         xx=xxsave
5488         write (2,*) "xx+ sumene from enesc=",sumenep
5489         yysave=yy
5490         yy=yy+aincr
5491         write (2,*) xx,yy,zz
5492         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5493         de_dyy_num=(sumenep-sumene)/aincr
5494         yy=yysave
5495         write (2,*) "yy+ sumene from enesc=",sumenep
5496         zzsave=zz
5497         zz=zz+aincr
5498         write (2,*) xx,yy,zz
5499         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5500         de_dzz_num=(sumenep-sumene)/aincr
5501         zz=zzsave
5502         write (2,*) "zz+ sumene from enesc=",sumenep
5503         costsave=cost2tab(i+1)
5504         sintsave=sint2tab(i+1)
5505         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5506         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5507         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5508         de_dt_num=(sumenep-sumene)/aincr
5509         write (2,*) " t+ sumene from enesc=",sumenep
5510         cost2tab(i+1)=costsave
5511         sint2tab(i+1)=sintsave
5512 C End of diagnostics section.
5513 #endif
5514 C
5515 C Compute the gradient of esc
5516 C
5517 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5518         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5519         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5520         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5521         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5522         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5523         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5524         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5525         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5526         pom1=(sumene3*sint2tab(i+1)+sumene1)
5527      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5528         pom2=(sumene4*cost2tab(i+1)+sumene2)
5529      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5530         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5531         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5532      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5533      &  +x(40)*yy*zz
5534         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5535         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5536      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5537      &  +x(60)*yy*zz
5538         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5539      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5540      &        +(pom1+pom2)*pom_dx
5541 #ifdef DEBUG
5542         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5543 #endif
5544 C
5545         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5546         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5547      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5548      &  +x(40)*xx*zz
5549         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5550         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5551      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5552      &  +x(59)*zz**2 +x(60)*xx*zz
5553         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5554      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5555      &        +(pom1-pom2)*pom_dy
5556 #ifdef DEBUG
5557         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5558 #endif
5559 C
5560         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5561      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5562      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5563      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5564      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5565      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5566      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5567      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5568 #ifdef DEBUG
5569         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5570 #endif
5571 C
5572         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5573      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5574      &  +pom1*pom_dt1+pom2*pom_dt2
5575 #ifdef DEBUG
5576         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5577 #endif
5578 c#undef DEBUG
5579 c
5580 C
5581        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5582        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5583        cosfac2xx=cosfac2*xx
5584        sinfac2yy=sinfac2*yy
5585        do k = 1,3
5586          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5587      &      vbld_inv(i+1)
5588          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5589      &      vbld_inv(i)
5590          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5591          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5592 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5593 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5594 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5595 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5596          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5597          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5598          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5599          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5600          dZZ_Ci1(k)=0.0d0
5601          dZZ_Ci(k)=0.0d0
5602          do j=1,3
5603            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5604      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5605            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5606      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5607          enddo
5608
5609          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5610          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5611          dZZ_XYZ(k)=vbld_inv(i+nres)*
5612      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5613 c
5614          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5615          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5616        enddo
5617
5618        do k=1,3
5619          dXX_Ctab(k,i)=dXX_Ci(k)
5620          dXX_C1tab(k,i)=dXX_Ci1(k)
5621          dYY_Ctab(k,i)=dYY_Ci(k)
5622          dYY_C1tab(k,i)=dYY_Ci1(k)
5623          dZZ_Ctab(k,i)=dZZ_Ci(k)
5624          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5625          dXX_XYZtab(k,i)=dXX_XYZ(k)
5626          dYY_XYZtab(k,i)=dYY_XYZ(k)
5627          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5628        enddo
5629
5630        do k = 1,3
5631 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5632 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5633 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5634 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5635 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5636 c     &    dt_dci(k)
5637 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5638 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5639          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5640      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5641          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5642      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5643          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5644      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5645        enddo
5646 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5647 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5648
5649 C to check gradient call subroutine check_grad
5650
5651     1 continue
5652       enddo
5653       return
5654       end
5655 c------------------------------------------------------------------------------
5656       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5657       implicit none
5658       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5659      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5660       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5661      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5662      &   + x(10)*yy*zz
5663       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5664      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5665      & + x(20)*yy*zz
5666       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5667      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5668      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5669      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5670      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5671      &  +x(40)*xx*yy*zz
5672       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5673      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5674      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5675      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5676      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5677      &  +x(60)*xx*yy*zz
5678       dsc_i   = 0.743d0+x(61)
5679       dp2_i   = 1.9d0+x(62)
5680       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5681      &          *(xx*cost2+yy*sint2))
5682       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5683      &          *(xx*cost2-yy*sint2))
5684       s1=(1+x(63))/(0.1d0 + dscp1)
5685       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5686       s2=(1+x(65))/(0.1d0 + dscp2)
5687       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5688       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5689      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5690       enesc=sumene
5691       return
5692       end
5693 #endif
5694 c------------------------------------------------------------------------------
5695       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5696 C
5697 C This procedure calculates two-body contact function g(rij) and its derivative:
5698 C
5699 C           eps0ij                                     !       x < -1
5700 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5701 C            0                                         !       x > 1
5702 C
5703 C where x=(rij-r0ij)/delta
5704 C
5705 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5706 C
5707       implicit none
5708       double precision rij,r0ij,eps0ij,fcont,fprimcont
5709       double precision x,x2,x4,delta
5710 c     delta=0.02D0*r0ij
5711 c      delta=0.2D0*r0ij
5712       x=(rij-r0ij)/delta
5713       if (x.lt.-1.0D0) then
5714         fcont=eps0ij
5715         fprimcont=0.0D0
5716       else if (x.le.1.0D0) then
5717         x2=x*x
5718         x4=x2*x2
5719         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5720         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5721       else
5722         fcont=0.0D0
5723         fprimcont=0.0D0
5724       endif
5725       return
5726       end
5727 c------------------------------------------------------------------------------
5728       subroutine splinthet(theti,delta,ss,ssder)
5729       implicit real*8 (a-h,o-z)
5730       include 'DIMENSIONS'
5731       include 'COMMON.VAR'
5732       include 'COMMON.GEO'
5733       thetup=pi-delta
5734       thetlow=delta
5735       if (theti.gt.pipol) then
5736         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5737       else
5738         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5739         ssder=-ssder
5740       endif
5741       return
5742       end
5743 c------------------------------------------------------------------------------
5744       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5745       implicit none
5746       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5747       double precision ksi,ksi2,ksi3,a1,a2,a3
5748       a1=fprim0*delta/(f1-f0)
5749       a2=3.0d0-2.0d0*a1
5750       a3=a1-2.0d0
5751       ksi=(x-x0)/delta
5752       ksi2=ksi*ksi
5753       ksi3=ksi2*ksi
5754       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5755       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5756       return
5757       end
5758 c------------------------------------------------------------------------------
5759       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5760       implicit none
5761       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5762       double precision ksi,ksi2,ksi3,a1,a2,a3
5763       ksi=(x-x0)/delta
5764       ksi2=ksi*ksi
5765       ksi3=ksi2*ksi
5766       a1=fprim0x*delta
5767       a2=3*(f1x-f0x)-2*fprim0x*delta
5768       a3=fprim0x*delta-2*(f1x-f0x)
5769       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5770       return
5771       end
5772 C-----------------------------------------------------------------------------
5773 #ifdef CRYST_TOR
5774 C-----------------------------------------------------------------------------
5775       subroutine etor(etors,edihcnstr)
5776       implicit real*8 (a-h,o-z)
5777       include 'DIMENSIONS'
5778       include 'COMMON.VAR'
5779       include 'COMMON.GEO'
5780       include 'COMMON.LOCAL'
5781       include 'COMMON.TORSION'
5782       include 'COMMON.INTERACT'
5783       include 'COMMON.DERIV'
5784       include 'COMMON.CHAIN'
5785       include 'COMMON.NAMES'
5786       include 'COMMON.IOUNITS'
5787       include 'COMMON.FFIELD'
5788       include 'COMMON.TORCNSTR'
5789       include 'COMMON.CONTROL'
5790       logical lprn
5791 C Set lprn=.true. for debugging
5792       lprn=.false.
5793 c      lprn=.true.
5794       etors=0.0D0
5795       do i=iphi_start,iphi_end
5796       etors_ii=0.0D0
5797         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5798      &      .or. itype(i).eq.ntyp1) cycle
5799         itori=itortyp(itype(i-2))
5800         itori1=itortyp(itype(i-1))
5801         phii=phi(i)
5802         gloci=0.0D0
5803 C Proline-Proline pair is a special case...
5804         if (itori.eq.3 .and. itori1.eq.3) then
5805           if (phii.gt.-dwapi3) then
5806             cosphi=dcos(3*phii)
5807             fac=1.0D0/(1.0D0-cosphi)
5808             etorsi=v1(1,3,3)*fac
5809             etorsi=etorsi+etorsi
5810             etors=etors+etorsi-v1(1,3,3)
5811             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5812             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5813           endif
5814           do j=1,3
5815             v1ij=v1(j+1,itori,itori1)
5816             v2ij=v2(j+1,itori,itori1)
5817             cosphi=dcos(j*phii)
5818             sinphi=dsin(j*phii)
5819             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5820             if (energy_dec) etors_ii=etors_ii+
5821      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5822             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5823           enddo
5824         else
5825           do j=1,nterm_old
5826             v1ij=v1(j,itori,itori1)
5827             v2ij=v2(j,itori,itori1)
5828             cosphi=dcos(j*phii)
5829             sinphi=dsin(j*phii)
5830             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5831             if (energy_dec) etors_ii=etors_ii+
5832      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5833             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5834           enddo
5835         endif
5836         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5837              'etor',i,etors_ii
5838         if (lprn)
5839      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5840      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5841      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5842         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5843 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5844       enddo
5845 ! 6/20/98 - dihedral angle constraints
5846       edihcnstr=0.0d0
5847       do i=1,ndih_constr
5848         itori=idih_constr(i)
5849         phii=phi(itori)
5850         difi=phii-phi0(i)
5851         if (difi.gt.drange(i)) then
5852           difi=difi-drange(i)
5853           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5854           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5855         else if (difi.lt.-drange(i)) then
5856           difi=difi+drange(i)
5857           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5858           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5859         endif
5860 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5861 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5862       enddo
5863 !      write (iout,*) 'edihcnstr',edihcnstr
5864       return
5865       end
5866 c------------------------------------------------------------------------------
5867       subroutine etor_d(etors_d)
5868       etors_d=0.0d0
5869       return
5870       end
5871 c----------------------------------------------------------------------------
5872 #else
5873       subroutine etor(etors,edihcnstr)
5874       implicit real*8 (a-h,o-z)
5875       include 'DIMENSIONS'
5876       include 'COMMON.VAR'
5877       include 'COMMON.GEO'
5878       include 'COMMON.LOCAL'
5879       include 'COMMON.TORSION'
5880       include 'COMMON.INTERACT'
5881       include 'COMMON.DERIV'
5882       include 'COMMON.CHAIN'
5883       include 'COMMON.NAMES'
5884       include 'COMMON.IOUNITS'
5885       include 'COMMON.FFIELD'
5886       include 'COMMON.TORCNSTR'
5887       include 'COMMON.CONTROL'
5888       logical lprn
5889 C Set lprn=.true. for debugging
5890       lprn=.false.
5891 c     lprn=.true.
5892       etors=0.0D0
5893       do i=iphi_start,iphi_end
5894 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5895         if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5896      &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5897      &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5898 C For introducing the NH3+ and COO- group please check the etor_d for reference
5899 C and guidance
5900         etors_ii=0.0D0
5901          if (iabs(itype(i)).eq.20) then
5902          iblock=2
5903          else
5904          iblock=1
5905          endif
5906         itori=itortyp(itype(i-2))
5907         itori1=itortyp(itype(i-1))
5908         phii=phi(i)
5909         gloci=0.0D0
5910 C Regular cosine and sine terms
5911         do j=1,nterm(itori,itori1,iblock)
5912           v1ij=v1(j,itori,itori1,iblock)
5913           v2ij=v2(j,itori,itori1,iblock)
5914           cosphi=dcos(j*phii)
5915           sinphi=dsin(j*phii)
5916           etors=etors+v1ij*cosphi+v2ij*sinphi
5917           if (energy_dec) etors_ii=etors_ii+
5918      &                v1ij*cosphi+v2ij*sinphi
5919           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5920         enddo
5921 C Lorentz terms
5922 C                         v1
5923 C  E = SUM ----------------------------------- - v1
5924 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5925 C
5926         cosphi=dcos(0.5d0*phii)
5927         sinphi=dsin(0.5d0*phii)
5928         do j=1,nlor(itori,itori1,iblock)
5929           vl1ij=vlor1(j,itori,itori1)
5930           vl2ij=vlor2(j,itori,itori1)
5931           vl3ij=vlor3(j,itori,itori1)
5932           pom=vl2ij*cosphi+vl3ij*sinphi
5933           pom1=1.0d0/(pom*pom+1.0d0)
5934           etors=etors+vl1ij*pom1
5935           if (energy_dec) etors_ii=etors_ii+
5936      &                vl1ij*pom1
5937           pom=-pom*pom1*pom1
5938           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5939         enddo
5940 C Subtract the constant term
5941         etors=etors-v0(itori,itori1,iblock)
5942           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5943      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5944         if (lprn)
5945      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5946      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5947      &  (v1(j,itori,itori1,iblock),j=1,6),
5948      &  (v2(j,itori,itori1,iblock),j=1,6)
5949         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5950 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5951       enddo
5952 ! 6/20/98 - dihedral angle constraints
5953       edihcnstr=0.0d0
5954 c      do i=1,ndih_constr
5955       do i=idihconstr_start,idihconstr_end
5956         itori=idih_constr(i)
5957         phii=phi(itori)
5958         difi=pinorm(phii-phi0(i))
5959         if (difi.gt.drange(i)) then
5960           difi=difi-drange(i)
5961           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5962           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5963         else if (difi.lt.-drange(i)) then
5964           difi=difi+drange(i)
5965           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5966           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5967         else
5968           difi=0.0
5969         endif
5970 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5971 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5972 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5973       enddo
5974 cd       write (iout,*) 'edihcnstr',edihcnstr
5975       return
5976       end
5977 c----------------------------------------------------------------------------
5978       subroutine etor_d(etors_d)
5979 C 6/23/01 Compute double torsional energy
5980       implicit real*8 (a-h,o-z)
5981       include 'DIMENSIONS'
5982       include 'COMMON.VAR'
5983       include 'COMMON.GEO'
5984       include 'COMMON.LOCAL'
5985       include 'COMMON.TORSION'
5986       include 'COMMON.INTERACT'
5987       include 'COMMON.DERIV'
5988       include 'COMMON.CHAIN'
5989       include 'COMMON.NAMES'
5990       include 'COMMON.IOUNITS'
5991       include 'COMMON.FFIELD'
5992       include 'COMMON.TORCNSTR'
5993       logical lprn
5994 C Set lprn=.true. for debugging
5995       lprn=.false.
5996 c     lprn=.true.
5997       etors_d=0.0D0
5998 c      write(iout,*) "a tu??"
5999       do i=iphid_start,iphid_end
6000 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6001         if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6002      &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6003      &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6004      &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6005         itori=itortyp(itype(i-2))
6006         itori1=itortyp(itype(i-1))
6007         itori2=itortyp(itype(i))
6008         phii=phi(i)
6009         phii1=phi(i+1)
6010         gloci1=0.0D0
6011         gloci2=0.0D0
6012         iblock=1
6013         if (iabs(itype(i+1)).eq.20) iblock=2
6014 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6015 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6016 C        if (itype(i+1).eq.ntyp1) iblock=3
6017 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6018 C IS or IS NOT need for this
6019 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6020 C        is (itype(i-3).eq.ntyp1) ntblock=2
6021 C        ntblock is N-terminal blocking group
6022
6023 C Regular cosine and sine terms
6024         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6025 C Example of changes for NH3+ blocking group
6026 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6027 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6028           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6029           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6030           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6031           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6032           cosphi1=dcos(j*phii)
6033           sinphi1=dsin(j*phii)
6034           cosphi2=dcos(j*phii1)
6035           sinphi2=dsin(j*phii1)
6036           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6037      &     v2cij*cosphi2+v2sij*sinphi2
6038           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6039           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6040         enddo
6041         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6042           do l=1,k-1
6043             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6044             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6045             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6046             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6047             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6048             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6049             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6050             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6051             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6052      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6053             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6054      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6055             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6056      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6057           enddo
6058         enddo
6059         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6060         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6061       enddo
6062       return
6063       end
6064 #endif
6065 c------------------------------------------------------------------------------
6066       subroutine eback_sc_corr(esccor)
6067 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6068 c        conformational states; temporarily implemented as differences
6069 c        between UNRES torsional potentials (dependent on three types of
6070 c        residues) and the torsional potentials dependent on all 20 types
6071 c        of residues computed from AM1  energy surfaces of terminally-blocked
6072 c        amino-acid residues.
6073       implicit real*8 (a-h,o-z)
6074       include 'DIMENSIONS'
6075       include 'COMMON.VAR'
6076       include 'COMMON.GEO'
6077       include 'COMMON.LOCAL'
6078       include 'COMMON.TORSION'
6079       include 'COMMON.SCCOR'
6080       include 'COMMON.INTERACT'
6081       include 'COMMON.DERIV'
6082       include 'COMMON.CHAIN'
6083       include 'COMMON.NAMES'
6084       include 'COMMON.IOUNITS'
6085       include 'COMMON.FFIELD'
6086       include 'COMMON.CONTROL'
6087       logical lprn
6088 C Set lprn=.true. for debugging
6089       lprn=.false.
6090 c      lprn=.true.
6091 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6092       esccor=0.0D0
6093       do i=itau_start,itau_end
6094         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6095         esccor_ii=0.0D0
6096         isccori=isccortyp(itype(i-2))
6097         isccori1=isccortyp(itype(i-1))
6098 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6099         phii=phi(i)
6100         do intertyp=1,3 !intertyp
6101 cc Added 09 May 2012 (Adasko)
6102 cc  Intertyp means interaction type of backbone mainchain correlation:
6103 c   1 = SC...Ca...Ca...Ca
6104 c   2 = Ca...Ca...Ca...SC
6105 c   3 = SC...Ca...Ca...SCi
6106         gloci=0.0D0
6107         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6108      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6109      &      (itype(i-1).eq.ntyp1)))
6110      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6111      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6112      &     .or.(itype(i).eq.ntyp1)))
6113      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6114      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6115      &      (itype(i-3).eq.ntyp1)))) cycle
6116         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6117         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6118      & cycle
6119        do j=1,nterm_sccor(isccori,isccori1)
6120           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6121           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6122           cosphi=dcos(j*tauangle(intertyp,i))
6123           sinphi=dsin(j*tauangle(intertyp,i))
6124           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6125           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6126         enddo
6127 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6128         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6129         if (lprn)
6130      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6131      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6132      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6133      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6134         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6135        enddo !intertyp
6136       enddo
6137
6138       return
6139       end
6140 c----------------------------------------------------------------------------
6141       subroutine multibody(ecorr)
6142 C This subroutine calculates multi-body contributions to energy following
6143 C the idea of Skolnick et al. If side chains I and J make a contact and
6144 C at the same time side chains I+1 and J+1 make a contact, an extra
6145 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6146       implicit real*8 (a-h,o-z)
6147       include 'DIMENSIONS'
6148       include 'COMMON.IOUNITS'
6149       include 'COMMON.DERIV'
6150       include 'COMMON.INTERACT'
6151       include 'COMMON.CONTACTS'
6152       double precision gx(3),gx1(3)
6153       logical lprn
6154
6155 C Set lprn=.true. for debugging
6156       lprn=.false.
6157
6158       if (lprn) then
6159         write (iout,'(a)') 'Contact function values:'
6160         do i=nnt,nct-2
6161           write (iout,'(i2,20(1x,i2,f10.5))')
6162      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6163         enddo
6164       endif
6165       ecorr=0.0D0
6166       do i=nnt,nct
6167         do j=1,3
6168           gradcorr(j,i)=0.0D0
6169           gradxorr(j,i)=0.0D0
6170         enddo
6171       enddo
6172       do i=nnt,nct-2
6173
6174         DO ISHIFT = 3,4
6175
6176         i1=i+ishift
6177         num_conti=num_cont(i)
6178         num_conti1=num_cont(i1)
6179         do jj=1,num_conti
6180           j=jcont(jj,i)
6181           do kk=1,num_conti1
6182             j1=jcont(kk,i1)
6183             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6184 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6185 cd   &                   ' ishift=',ishift
6186 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6187 C The system gains extra energy.
6188               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6189             endif   ! j1==j+-ishift
6190           enddo     ! kk
6191         enddo       ! jj
6192
6193         ENDDO ! ISHIFT
6194
6195       enddo         ! i
6196       return
6197       end
6198 c------------------------------------------------------------------------------
6199       double precision function esccorr(i,j,k,l,jj,kk)
6200       implicit real*8 (a-h,o-z)
6201       include 'DIMENSIONS'
6202       include 'COMMON.IOUNITS'
6203       include 'COMMON.DERIV'
6204       include 'COMMON.INTERACT'
6205       include 'COMMON.CONTACTS'
6206       double precision gx(3),gx1(3)
6207       logical lprn
6208       lprn=.false.
6209       eij=facont(jj,i)
6210       ekl=facont(kk,k)
6211 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6212 C Calculate the multi-body contribution to energy.
6213 C Calculate multi-body contributions to the gradient.
6214 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6215 cd   & k,l,(gacont(m,kk,k),m=1,3)
6216       do m=1,3
6217         gx(m) =ekl*gacont(m,jj,i)
6218         gx1(m)=eij*gacont(m,kk,k)
6219         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6220         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6221         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6222         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6223       enddo
6224       do m=i,j-1
6225         do ll=1,3
6226           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6227         enddo
6228       enddo
6229       do m=k,l-1
6230         do ll=1,3
6231           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6232         enddo
6233       enddo
6234       esccorr=-eij*ekl
6235       return
6236       end
6237 c------------------------------------------------------------------------------
6238       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6239 C This subroutine calculates multi-body contributions to hydrogen-bonding
6240       implicit real*8 (a-h,o-z)
6241       include 'DIMENSIONS'
6242       include 'COMMON.IOUNITS'
6243 #ifdef MPI
6244       include "mpif.h"
6245       parameter (max_cont=maxconts)
6246       parameter (max_dim=26)
6247       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6248       double precision zapas(max_dim,maxconts,max_fg_procs),
6249      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6250       common /przechowalnia/ zapas
6251       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6252      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6253 #endif
6254       include 'COMMON.SETUP'
6255       include 'COMMON.FFIELD'
6256       include 'COMMON.DERIV'
6257       include 'COMMON.INTERACT'
6258       include 'COMMON.CONTACTS'
6259       include 'COMMON.CONTROL'
6260       include 'COMMON.LOCAL'
6261       double precision gx(3),gx1(3),time00
6262       logical lprn,ldone
6263
6264 C Set lprn=.true. for debugging
6265       lprn=.false.
6266 #ifdef MPI
6267       n_corr=0
6268       n_corr1=0
6269       if (nfgtasks.le.1) goto 30
6270       if (lprn) then
6271         write (iout,'(a)') 'Contact function values before RECEIVE:'
6272         do i=nnt,nct-2
6273           write (iout,'(2i3,50(1x,i2,f5.2))')
6274      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6275      &    j=1,num_cont_hb(i))
6276         enddo
6277       endif
6278       call flush(iout)
6279       do i=1,ntask_cont_from
6280         ncont_recv(i)=0
6281       enddo
6282       do i=1,ntask_cont_to
6283         ncont_sent(i)=0
6284       enddo
6285 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6286 c     & ntask_cont_to
6287 C Make the list of contacts to send to send to other procesors
6288 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6289 c      call flush(iout)
6290       do i=iturn3_start,iturn3_end
6291 c        write (iout,*) "make contact list turn3",i," num_cont",
6292 c     &    num_cont_hb(i)
6293         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6294       enddo
6295       do i=iturn4_start,iturn4_end
6296 c        write (iout,*) "make contact list turn4",i," num_cont",
6297 c     &   num_cont_hb(i)
6298         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6299       enddo
6300       do ii=1,nat_sent
6301         i=iat_sent(ii)
6302 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6303 c     &    num_cont_hb(i)
6304         do j=1,num_cont_hb(i)
6305         do k=1,4
6306           jjc=jcont_hb(j,i)
6307           iproc=iint_sent_local(k,jjc,ii)
6308 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6309           if (iproc.gt.0) then
6310             ncont_sent(iproc)=ncont_sent(iproc)+1
6311             nn=ncont_sent(iproc)
6312             zapas(1,nn,iproc)=i
6313             zapas(2,nn,iproc)=jjc
6314             zapas(3,nn,iproc)=facont_hb(j,i)
6315             zapas(4,nn,iproc)=ees0p(j,i)
6316             zapas(5,nn,iproc)=ees0m(j,i)
6317             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6318             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6319             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6320             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6321             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6322             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6323             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6324             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6325             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6326             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6327             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6328             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6329             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6330             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6331             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6332             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6333             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6334             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6335             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6336             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6337             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6338           endif
6339         enddo
6340         enddo
6341       enddo
6342       if (lprn) then
6343       write (iout,*)
6344      &  "Numbers of contacts to be sent to other processors",
6345      &  (ncont_sent(i),i=1,ntask_cont_to)
6346       write (iout,*) "Contacts sent"
6347       do ii=1,ntask_cont_to
6348         nn=ncont_sent(ii)
6349         iproc=itask_cont_to(ii)
6350         write (iout,*) nn," contacts to processor",iproc,
6351      &   " of CONT_TO_COMM group"
6352         do i=1,nn
6353           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6354         enddo
6355       enddo
6356       call flush(iout)
6357       endif
6358       CorrelType=477
6359       CorrelID=fg_rank+1
6360       CorrelType1=478
6361       CorrelID1=nfgtasks+fg_rank+1
6362       ireq=0
6363 C Receive the numbers of needed contacts from other processors
6364       do ii=1,ntask_cont_from
6365         iproc=itask_cont_from(ii)
6366         ireq=ireq+1
6367         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6368      &    FG_COMM,req(ireq),IERR)
6369       enddo
6370 c      write (iout,*) "IRECV ended"
6371 c      call flush(iout)
6372 C Send the number of contacts needed by other processors
6373       do ii=1,ntask_cont_to
6374         iproc=itask_cont_to(ii)
6375         ireq=ireq+1
6376         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6377      &    FG_COMM,req(ireq),IERR)
6378       enddo
6379 c      write (iout,*) "ISEND ended"
6380 c      write (iout,*) "number of requests (nn)",ireq
6381       call flush(iout)
6382       if (ireq.gt.0)
6383      &  call MPI_Waitall(ireq,req,status_array,ierr)
6384 c      write (iout,*)
6385 c     &  "Numbers of contacts to be received from other processors",
6386 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6387 c      call flush(iout)
6388 C Receive contacts
6389       ireq=0
6390       do ii=1,ntask_cont_from
6391         iproc=itask_cont_from(ii)
6392         nn=ncont_recv(ii)
6393 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6394 c     &   " of CONT_TO_COMM group"
6395         call flush(iout)
6396         if (nn.gt.0) then
6397           ireq=ireq+1
6398           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6399      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6400 c          write (iout,*) "ireq,req",ireq,req(ireq)
6401         endif
6402       enddo
6403 C Send the contacts to processors that need them
6404       do ii=1,ntask_cont_to
6405         iproc=itask_cont_to(ii)
6406         nn=ncont_sent(ii)
6407 c        write (iout,*) nn," contacts to processor",iproc,
6408 c     &   " of CONT_TO_COMM group"
6409         if (nn.gt.0) then
6410           ireq=ireq+1
6411           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6412      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6413 c          write (iout,*) "ireq,req",ireq,req(ireq)
6414 c          do i=1,nn
6415 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6416 c          enddo
6417         endif
6418       enddo
6419 c      write (iout,*) "number of requests (contacts)",ireq
6420 c      write (iout,*) "req",(req(i),i=1,4)
6421 c      call flush(iout)
6422       if (ireq.gt.0)
6423      & call MPI_Waitall(ireq,req,status_array,ierr)
6424       do iii=1,ntask_cont_from
6425         iproc=itask_cont_from(iii)
6426         nn=ncont_recv(iii)
6427         if (lprn) then
6428         write (iout,*) "Received",nn," contacts from processor",iproc,
6429      &   " of CONT_FROM_COMM group"
6430         call flush(iout)
6431         do i=1,nn
6432           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6433         enddo
6434         call flush(iout)
6435         endif
6436         do i=1,nn
6437           ii=zapas_recv(1,i,iii)
6438 c Flag the received contacts to prevent double-counting
6439           jj=-zapas_recv(2,i,iii)
6440 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6441 c          call flush(iout)
6442           nnn=num_cont_hb(ii)+1
6443           num_cont_hb(ii)=nnn
6444           jcont_hb(nnn,ii)=jj
6445           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6446           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6447           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6448           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6449           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6450           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6451           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6452           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6453           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6454           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6455           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6456           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6457           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6458           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6459           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6460           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6461           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6462           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6463           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6464           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6465           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6466           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6467           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6468           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6469         enddo
6470       enddo
6471       call flush(iout)
6472       if (lprn) then
6473         write (iout,'(a)') 'Contact function values after receive:'
6474         do i=nnt,nct-2
6475           write (iout,'(2i3,50(1x,i3,f5.2))')
6476      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6477      &    j=1,num_cont_hb(i))
6478         enddo
6479         call flush(iout)
6480       endif
6481    30 continue
6482 #endif
6483       if (lprn) then
6484         write (iout,'(a)') 'Contact function values:'
6485         do i=nnt,nct-2
6486           write (iout,'(2i3,50(1x,i3,f5.2))')
6487      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6488      &    j=1,num_cont_hb(i))
6489         enddo
6490       endif
6491       ecorr=0.0D0
6492 C Remove the loop below after debugging !!!
6493       do i=nnt,nct
6494         do j=1,3
6495           gradcorr(j,i)=0.0D0
6496           gradxorr(j,i)=0.0D0
6497         enddo
6498       enddo
6499 C Calculate the local-electrostatic correlation terms
6500       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6501         i1=i+1
6502         num_conti=num_cont_hb(i)
6503         num_conti1=num_cont_hb(i+1)
6504         do jj=1,num_conti
6505           j=jcont_hb(jj,i)
6506           jp=iabs(j)
6507           do kk=1,num_conti1
6508             j1=jcont_hb(kk,i1)
6509             jp1=iabs(j1)
6510 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6511 c     &         ' jj=',jj,' kk=',kk
6512             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6513      &          .or. j.lt.0 .and. j1.gt.0) .and.
6514      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6515 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6516 C The system gains extra energy.
6517               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6518               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6519      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6520               n_corr=n_corr+1
6521             else if (j1.eq.j) then
6522 C Contacts I-J and I-(J+1) occur simultaneously.
6523 C The system loses extra energy.
6524 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6525             endif
6526           enddo ! kk
6527           do kk=1,num_conti
6528             j1=jcont_hb(kk,i)
6529 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6530 c    &         ' jj=',jj,' kk=',kk
6531             if (j1.eq.j+1) then
6532 C Contacts I-J and (I+1)-J occur simultaneously.
6533 C The system loses extra energy.
6534 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6535             endif ! j1==j+1
6536           enddo ! kk
6537         enddo ! jj
6538       enddo ! i
6539       return
6540       end
6541 c------------------------------------------------------------------------------
6542       subroutine add_hb_contact(ii,jj,itask)
6543       implicit real*8 (a-h,o-z)
6544       include "DIMENSIONS"
6545       include "COMMON.IOUNITS"
6546       integer max_cont
6547       integer max_dim
6548       parameter (max_cont=maxconts)
6549       parameter (max_dim=26)
6550       include "COMMON.CONTACTS"
6551       double precision zapas(max_dim,maxconts,max_fg_procs),
6552      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6553       common /przechowalnia/ zapas
6554       integer i,j,ii,jj,iproc,itask(4),nn
6555 c      write (iout,*) "itask",itask
6556       do i=1,2
6557         iproc=itask(i)
6558         if (iproc.gt.0) then
6559           do j=1,num_cont_hb(ii)
6560             jjc=jcont_hb(j,ii)
6561 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6562             if (jjc.eq.jj) then
6563               ncont_sent(iproc)=ncont_sent(iproc)+1
6564               nn=ncont_sent(iproc)
6565               zapas(1,nn,iproc)=ii
6566               zapas(2,nn,iproc)=jjc
6567               zapas(3,nn,iproc)=facont_hb(j,ii)
6568               zapas(4,nn,iproc)=ees0p(j,ii)
6569               zapas(5,nn,iproc)=ees0m(j,ii)
6570               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6571               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6572               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6573               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6574               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6575               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6576               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6577               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6578               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6579               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6580               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6581               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6582               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6583               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6584               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6585               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6586               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6587               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6588               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6589               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6590               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6591               exit
6592             endif
6593           enddo
6594         endif
6595       enddo
6596       return
6597       end
6598 c------------------------------------------------------------------------------
6599       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6600      &  n_corr1)
6601 C This subroutine calculates multi-body contributions to hydrogen-bonding
6602       implicit real*8 (a-h,o-z)
6603       include 'DIMENSIONS'
6604       include 'COMMON.IOUNITS'
6605 #ifdef MPI
6606       include "mpif.h"
6607       parameter (max_cont=maxconts)
6608       parameter (max_dim=70)
6609       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6610       double precision zapas(max_dim,maxconts,max_fg_procs),
6611      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6612       common /przechowalnia/ zapas
6613       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6614      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6615 #endif
6616       include 'COMMON.SETUP'
6617       include 'COMMON.FFIELD'
6618       include 'COMMON.DERIV'
6619       include 'COMMON.LOCAL'
6620       include 'COMMON.INTERACT'
6621       include 'COMMON.CONTACTS'
6622       include 'COMMON.CHAIN'
6623       include 'COMMON.CONTROL'
6624       double precision gx(3),gx1(3)
6625       integer num_cont_hb_old(maxres)
6626       logical lprn,ldone
6627       double precision eello4,eello5,eelo6,eello_turn6
6628       external eello4,eello5,eello6,eello_turn6
6629 C Set lprn=.true. for debugging
6630       lprn=.false.
6631       eturn6=0.0d0
6632 #ifdef MPI
6633       do i=1,nres
6634         num_cont_hb_old(i)=num_cont_hb(i)
6635       enddo
6636       n_corr=0
6637       n_corr1=0
6638       if (nfgtasks.le.1) goto 30
6639       if (lprn) then
6640         write (iout,'(a)') 'Contact function values before RECEIVE:'
6641         do i=nnt,nct-2
6642           write (iout,'(2i3,50(1x,i2,f5.2))')
6643      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6644      &    j=1,num_cont_hb(i))
6645         enddo
6646       endif
6647       call flush(iout)
6648       do i=1,ntask_cont_from
6649         ncont_recv(i)=0
6650       enddo
6651       do i=1,ntask_cont_to
6652         ncont_sent(i)=0
6653       enddo
6654 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6655 c     & ntask_cont_to
6656 C Make the list of contacts to send to send to other procesors
6657       do i=iturn3_start,iturn3_end
6658 c        write (iout,*) "make contact list turn3",i," num_cont",
6659 c     &    num_cont_hb(i)
6660         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6661       enddo
6662       do i=iturn4_start,iturn4_end
6663 c        write (iout,*) "make contact list turn4",i," num_cont",
6664 c     &   num_cont_hb(i)
6665         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6666       enddo
6667       do ii=1,nat_sent
6668         i=iat_sent(ii)
6669 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6670 c     &    num_cont_hb(i)
6671         do j=1,num_cont_hb(i)
6672         do k=1,4
6673           jjc=jcont_hb(j,i)
6674           iproc=iint_sent_local(k,jjc,ii)
6675 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6676           if (iproc.ne.0) then
6677             ncont_sent(iproc)=ncont_sent(iproc)+1
6678             nn=ncont_sent(iproc)
6679             zapas(1,nn,iproc)=i
6680             zapas(2,nn,iproc)=jjc
6681             zapas(3,nn,iproc)=d_cont(j,i)
6682             ind=3
6683             do kk=1,3
6684               ind=ind+1
6685               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6686             enddo
6687             do kk=1,2
6688               do ll=1,2
6689                 ind=ind+1
6690                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6691               enddo
6692             enddo
6693             do jj=1,5
6694               do kk=1,3
6695                 do ll=1,2
6696                   do mm=1,2
6697                     ind=ind+1
6698                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6699                   enddo
6700                 enddo
6701               enddo
6702             enddo
6703           endif
6704         enddo
6705         enddo
6706       enddo
6707       if (lprn) then
6708       write (iout,*)
6709      &  "Numbers of contacts to be sent to other processors",
6710      &  (ncont_sent(i),i=1,ntask_cont_to)
6711       write (iout,*) "Contacts sent"
6712       do ii=1,ntask_cont_to
6713         nn=ncont_sent(ii)
6714         iproc=itask_cont_to(ii)
6715         write (iout,*) nn," contacts to processor",iproc,
6716      &   " of CONT_TO_COMM group"
6717         do i=1,nn
6718           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6719         enddo
6720       enddo
6721       call flush(iout)
6722       endif
6723       CorrelType=477
6724       CorrelID=fg_rank+1
6725       CorrelType1=478
6726       CorrelID1=nfgtasks+fg_rank+1
6727       ireq=0
6728 C Receive the numbers of needed contacts from other processors
6729       do ii=1,ntask_cont_from
6730         iproc=itask_cont_from(ii)
6731         ireq=ireq+1
6732         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6733      &    FG_COMM,req(ireq),IERR)
6734       enddo
6735 c      write (iout,*) "IRECV ended"
6736 c      call flush(iout)
6737 C Send the number of contacts needed by other processors
6738       do ii=1,ntask_cont_to
6739         iproc=itask_cont_to(ii)
6740         ireq=ireq+1
6741         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6742      &    FG_COMM,req(ireq),IERR)
6743       enddo
6744 c      write (iout,*) "ISEND ended"
6745 c      write (iout,*) "number of requests (nn)",ireq
6746       call flush(iout)
6747       if (ireq.gt.0)
6748      &  call MPI_Waitall(ireq,req,status_array,ierr)
6749 c      write (iout,*)
6750 c     &  "Numbers of contacts to be received from other processors",
6751 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6752 c      call flush(iout)
6753 C Receive contacts
6754       ireq=0
6755       do ii=1,ntask_cont_from
6756         iproc=itask_cont_from(ii)
6757         nn=ncont_recv(ii)
6758 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6759 c     &   " of CONT_TO_COMM group"
6760         call flush(iout)
6761         if (nn.gt.0) then
6762           ireq=ireq+1
6763           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6764      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6765 c          write (iout,*) "ireq,req",ireq,req(ireq)
6766         endif
6767       enddo
6768 C Send the contacts to processors that need them
6769       do ii=1,ntask_cont_to
6770         iproc=itask_cont_to(ii)
6771         nn=ncont_sent(ii)
6772 c        write (iout,*) nn," contacts to processor",iproc,
6773 c     &   " of CONT_TO_COMM group"
6774         if (nn.gt.0) then
6775           ireq=ireq+1
6776           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6777      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6778 c          write (iout,*) "ireq,req",ireq,req(ireq)
6779 c          do i=1,nn
6780 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6781 c          enddo
6782         endif
6783       enddo
6784 c      write (iout,*) "number of requests (contacts)",ireq
6785 c      write (iout,*) "req",(req(i),i=1,4)
6786 c      call flush(iout)
6787       if (ireq.gt.0)
6788      & call MPI_Waitall(ireq,req,status_array,ierr)
6789       do iii=1,ntask_cont_from
6790         iproc=itask_cont_from(iii)
6791         nn=ncont_recv(iii)
6792         if (lprn) then
6793         write (iout,*) "Received",nn," contacts from processor",iproc,
6794      &   " of CONT_FROM_COMM group"
6795         call flush(iout)
6796         do i=1,nn
6797           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6798         enddo
6799         call flush(iout)
6800         endif
6801         do i=1,nn
6802           ii=zapas_recv(1,i,iii)
6803 c Flag the received contacts to prevent double-counting
6804           jj=-zapas_recv(2,i,iii)
6805 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6806 c          call flush(iout)
6807           nnn=num_cont_hb(ii)+1
6808           num_cont_hb(ii)=nnn
6809           jcont_hb(nnn,ii)=jj
6810           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6811           ind=3
6812           do kk=1,3
6813             ind=ind+1
6814             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6815           enddo
6816           do kk=1,2
6817             do ll=1,2
6818               ind=ind+1
6819               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6820             enddo
6821           enddo
6822           do jj=1,5
6823             do kk=1,3
6824               do ll=1,2
6825                 do mm=1,2
6826                   ind=ind+1
6827                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6828                 enddo
6829               enddo
6830             enddo
6831           enddo
6832         enddo
6833       enddo
6834       call flush(iout)
6835       if (lprn) then
6836         write (iout,'(a)') 'Contact function values after receive:'
6837         do i=nnt,nct-2
6838           write (iout,'(2i3,50(1x,i3,5f6.3))')
6839      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6840      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6841         enddo
6842         call flush(iout)
6843       endif
6844    30 continue
6845 #endif
6846       if (lprn) then
6847         write (iout,'(a)') 'Contact function values:'
6848         do i=nnt,nct-2
6849           write (iout,'(2i3,50(1x,i2,5f6.3))')
6850      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6851      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6852         enddo
6853       endif
6854       ecorr=0.0D0
6855       ecorr5=0.0d0
6856       ecorr6=0.0d0
6857 C Remove the loop below after debugging !!!
6858       do i=nnt,nct
6859         do j=1,3
6860           gradcorr(j,i)=0.0D0
6861           gradxorr(j,i)=0.0D0
6862         enddo
6863       enddo
6864 C Calculate the dipole-dipole interaction energies
6865       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6866       do i=iatel_s,iatel_e+1
6867         num_conti=num_cont_hb(i)
6868         do jj=1,num_conti
6869           j=jcont_hb(jj,i)
6870 #ifdef MOMENT
6871           call dipole(i,j,jj)
6872 #endif
6873         enddo
6874       enddo
6875       endif
6876 C Calculate the local-electrostatic correlation terms
6877 c                write (iout,*) "gradcorr5 in eello5 before loop"
6878 c                do iii=1,nres
6879 c                  write (iout,'(i5,3f10.5)')
6880 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6881 c                enddo
6882       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6883 c        write (iout,*) "corr loop i",i
6884         i1=i+1
6885         num_conti=num_cont_hb(i)
6886         num_conti1=num_cont_hb(i+1)
6887         do jj=1,num_conti
6888           j=jcont_hb(jj,i)
6889           jp=iabs(j)
6890           do kk=1,num_conti1
6891             j1=jcont_hb(kk,i1)
6892             jp1=iabs(j1)
6893 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6894 c     &         ' jj=',jj,' kk=',kk
6895 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6896             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6897      &          .or. j.lt.0 .and. j1.gt.0) .and.
6898      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6899 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6900 C The system gains extra energy.
6901               n_corr=n_corr+1
6902               sqd1=dsqrt(d_cont(jj,i))
6903               sqd2=dsqrt(d_cont(kk,i1))
6904               sred_geom = sqd1*sqd2
6905               IF (sred_geom.lt.cutoff_corr) THEN
6906                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6907      &            ekont,fprimcont)
6908 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6909 cd     &         ' jj=',jj,' kk=',kk
6910                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6911                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6912                 do l=1,3
6913                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6914                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6915                 enddo
6916                 n_corr1=n_corr1+1
6917 cd               write (iout,*) 'sred_geom=',sred_geom,
6918 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6919 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6920 cd               write (iout,*) "g_contij",g_contij
6921 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6922 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6923                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6924                 if (wcorr4.gt.0.0d0)
6925      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6926                   if (energy_dec.and.wcorr4.gt.0.0d0)
6927      1                 write (iout,'(a6,4i5,0pf7.3)')
6928      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6929 c                write (iout,*) "gradcorr5 before eello5"
6930 c                do iii=1,nres
6931 c                  write (iout,'(i5,3f10.5)')
6932 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6933 c                enddo
6934                 if (wcorr5.gt.0.0d0)
6935      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6936 c                write (iout,*) "gradcorr5 after eello5"
6937 c                do iii=1,nres
6938 c                  write (iout,'(i5,3f10.5)')
6939 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6940 c                enddo
6941                   if (energy_dec.and.wcorr5.gt.0.0d0)
6942      1                 write (iout,'(a6,4i5,0pf7.3)')
6943      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6944 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6945 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6946                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6947      &               .or. wturn6.eq.0.0d0))then
6948 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6949                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6950                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6951      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6952 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6953 cd     &            'ecorr6=',ecorr6
6954 cd                write (iout,'(4e15.5)') sred_geom,
6955 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6956 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6957 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6958                 else if (wturn6.gt.0.0d0
6959      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6960 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6961                   eturn6=eturn6+eello_turn6(i,jj,kk)
6962                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6963      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6964 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6965                 endif
6966               ENDIF
6967 1111          continue
6968             endif
6969           enddo ! kk
6970         enddo ! jj
6971       enddo ! i
6972       do i=1,nres
6973         num_cont_hb(i)=num_cont_hb_old(i)
6974       enddo
6975 c                write (iout,*) "gradcorr5 in eello5"
6976 c                do iii=1,nres
6977 c                  write (iout,'(i5,3f10.5)')
6978 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6979 c                enddo
6980       return
6981       end
6982 c------------------------------------------------------------------------------
6983       subroutine add_hb_contact_eello(ii,jj,itask)
6984       implicit real*8 (a-h,o-z)
6985       include "DIMENSIONS"
6986       include "COMMON.IOUNITS"
6987       integer max_cont
6988       integer max_dim
6989       parameter (max_cont=maxconts)
6990       parameter (max_dim=70)
6991       include "COMMON.CONTACTS"
6992       double precision zapas(max_dim,maxconts,max_fg_procs),
6993      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6994       common /przechowalnia/ zapas
6995       integer i,j,ii,jj,iproc,itask(4),nn
6996 c      write (iout,*) "itask",itask
6997       do i=1,2
6998         iproc=itask(i)
6999         if (iproc.gt.0) then
7000           do j=1,num_cont_hb(ii)
7001             jjc=jcont_hb(j,ii)
7002 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7003             if (jjc.eq.jj) then
7004               ncont_sent(iproc)=ncont_sent(iproc)+1
7005               nn=ncont_sent(iproc)
7006               zapas(1,nn,iproc)=ii
7007               zapas(2,nn,iproc)=jjc
7008               zapas(3,nn,iproc)=d_cont(j,ii)
7009               ind=3
7010               do kk=1,3
7011                 ind=ind+1
7012                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7013               enddo
7014               do kk=1,2
7015                 do ll=1,2
7016                   ind=ind+1
7017                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7018                 enddo
7019               enddo
7020               do jj=1,5
7021                 do kk=1,3
7022                   do ll=1,2
7023                     do mm=1,2
7024                       ind=ind+1
7025                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7026                     enddo
7027                   enddo
7028                 enddo
7029               enddo
7030               exit
7031             endif
7032           enddo
7033         endif
7034       enddo
7035       return
7036       end
7037 c------------------------------------------------------------------------------
7038       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7039       implicit real*8 (a-h,o-z)
7040       include 'DIMENSIONS'
7041       include 'COMMON.IOUNITS'
7042       include 'COMMON.DERIV'
7043       include 'COMMON.INTERACT'
7044       include 'COMMON.CONTACTS'
7045       double precision gx(3),gx1(3)
7046       logical lprn
7047       lprn=.false.
7048       eij=facont_hb(jj,i)
7049       ekl=facont_hb(kk,k)
7050       ees0pij=ees0p(jj,i)
7051       ees0pkl=ees0p(kk,k)
7052       ees0mij=ees0m(jj,i)
7053       ees0mkl=ees0m(kk,k)
7054       ekont=eij*ekl
7055       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7056 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7057 C Following 4 lines for diagnostics.
7058 cd    ees0pkl=0.0D0
7059 cd    ees0pij=1.0D0
7060 cd    ees0mkl=0.0D0
7061 cd    ees0mij=1.0D0
7062 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7063 c     & 'Contacts ',i,j,
7064 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7065 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7066 c     & 'gradcorr_long'
7067 C Calculate the multi-body contribution to energy.
7068 c      ecorr=ecorr+ekont*ees
7069 C Calculate multi-body contributions to the gradient.
7070       coeffpees0pij=coeffp*ees0pij
7071       coeffmees0mij=coeffm*ees0mij
7072       coeffpees0pkl=coeffp*ees0pkl
7073       coeffmees0mkl=coeffm*ees0mkl
7074       do ll=1,3
7075 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7076         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7077      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7078      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7079         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7080      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7081      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7082 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7083         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7084      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7085      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7086         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7087      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7088      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7089         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7090      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7091      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7092         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7093         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7094         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7095      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7096      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7097         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7098         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7099 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7100       enddo
7101 c      write (iout,*)
7102 cgrad      do m=i+1,j-1
7103 cgrad        do ll=1,3
7104 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7105 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7106 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7107 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7108 cgrad        enddo
7109 cgrad      enddo
7110 cgrad      do m=k+1,l-1
7111 cgrad        do ll=1,3
7112 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7113 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7114 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7115 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7116 cgrad        enddo
7117 cgrad      enddo
7118 c      write (iout,*) "ehbcorr",ekont*ees
7119       ehbcorr=ekont*ees
7120       return
7121       end
7122 #ifdef MOMENT
7123 C---------------------------------------------------------------------------
7124       subroutine dipole(i,j,jj)
7125       implicit real*8 (a-h,o-z)
7126       include 'DIMENSIONS'
7127       include 'COMMON.IOUNITS'
7128       include 'COMMON.CHAIN'
7129       include 'COMMON.FFIELD'
7130       include 'COMMON.DERIV'
7131       include 'COMMON.INTERACT'
7132       include 'COMMON.CONTACTS'
7133       include 'COMMON.TORSION'
7134       include 'COMMON.VAR'
7135       include 'COMMON.GEO'
7136       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7137      &  auxmat(2,2)
7138       iti1 = itortyp(itype(i+1))
7139       if (j.lt.nres-1) then
7140         itj1 = itortyp(itype(j+1))
7141       else
7142         itj1=ntortyp+1
7143       endif
7144       do iii=1,2
7145         dipi(iii,1)=Ub2(iii,i)
7146         dipderi(iii)=Ub2der(iii,i)
7147         dipi(iii,2)=b1(iii,iti1)
7148         dipj(iii,1)=Ub2(iii,j)
7149         dipderj(iii)=Ub2der(iii,j)
7150         dipj(iii,2)=b1(iii,itj1)
7151       enddo
7152       kkk=0
7153       do iii=1,2
7154         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7155         do jjj=1,2
7156           kkk=kkk+1
7157           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7158         enddo
7159       enddo
7160       do kkk=1,5
7161         do lll=1,3
7162           mmm=0
7163           do iii=1,2
7164             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7165      &        auxvec(1))
7166             do jjj=1,2
7167               mmm=mmm+1
7168               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7169             enddo
7170           enddo
7171         enddo
7172       enddo
7173       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7174       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7175       do iii=1,2
7176         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7177       enddo
7178       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7179       do iii=1,2
7180         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7181       enddo
7182       return
7183       end
7184 #endif
7185 C---------------------------------------------------------------------------
7186       subroutine calc_eello(i,j,k,l,jj,kk)
7187 C
7188 C This subroutine computes matrices and vectors needed to calculate
7189 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7190 C
7191       implicit real*8 (a-h,o-z)
7192       include 'DIMENSIONS'
7193       include 'COMMON.IOUNITS'
7194       include 'COMMON.CHAIN'
7195       include 'COMMON.DERIV'
7196       include 'COMMON.INTERACT'
7197       include 'COMMON.CONTACTS'
7198       include 'COMMON.TORSION'
7199       include 'COMMON.VAR'
7200       include 'COMMON.GEO'
7201       include 'COMMON.FFIELD'
7202       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7203      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7204       logical lprn
7205       common /kutas/ lprn
7206 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7207 cd     & ' jj=',jj,' kk=',kk
7208 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7209 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7210 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7211       do iii=1,2
7212         do jjj=1,2
7213           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7214           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7215         enddo
7216       enddo
7217       call transpose2(aa1(1,1),aa1t(1,1))
7218       call transpose2(aa2(1,1),aa2t(1,1))
7219       do kkk=1,5
7220         do lll=1,3
7221           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7222      &      aa1tder(1,1,lll,kkk))
7223           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7224      &      aa2tder(1,1,lll,kkk))
7225         enddo
7226       enddo
7227       if (l.eq.j+1) then
7228 C parallel orientation of the two CA-CA-CA frames.
7229         if (i.gt.1) then
7230           iti=itortyp(itype(i))
7231         else
7232           iti=ntortyp+1
7233         endif
7234         itk1=itortyp(itype(k+1))
7235         itj=itortyp(itype(j))
7236         if (l.lt.nres-1) then
7237           itl1=itortyp(itype(l+1))
7238         else
7239           itl1=ntortyp+1
7240         endif
7241 C A1 kernel(j+1) A2T
7242 cd        do iii=1,2
7243 cd          write (iout,'(3f10.5,5x,3f10.5)')
7244 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7245 cd        enddo
7246         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7247      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7248      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7249 C Following matrices are needed only for 6-th order cumulants
7250         IF (wcorr6.gt.0.0d0) THEN
7251         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7252      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7253      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7254         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7255      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7256      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7257      &   ADtEAderx(1,1,1,1,1,1))
7258         lprn=.false.
7259         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7260      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7261      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7262      &   ADtEA1derx(1,1,1,1,1,1))
7263         ENDIF
7264 C End 6-th order cumulants
7265 cd        lprn=.false.
7266 cd        if (lprn) then
7267 cd        write (2,*) 'In calc_eello6'
7268 cd        do iii=1,2
7269 cd          write (2,*) 'iii=',iii
7270 cd          do kkk=1,5
7271 cd            write (2,*) 'kkk=',kkk
7272 cd            do jjj=1,2
7273 cd              write (2,'(3(2f10.5),5x)')
7274 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7275 cd            enddo
7276 cd          enddo
7277 cd        enddo
7278 cd        endif
7279         call transpose2(EUgder(1,1,k),auxmat(1,1))
7280         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7281         call transpose2(EUg(1,1,k),auxmat(1,1))
7282         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7283         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7284         do iii=1,2
7285           do kkk=1,5
7286             do lll=1,3
7287               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7288      &          EAEAderx(1,1,lll,kkk,iii,1))
7289             enddo
7290           enddo
7291         enddo
7292 C A1T kernel(i+1) A2
7293         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7294      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7295      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7296 C Following matrices are needed only for 6-th order cumulants
7297         IF (wcorr6.gt.0.0d0) THEN
7298         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7299      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7300      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7301         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7302      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7303      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7304      &   ADtEAderx(1,1,1,1,1,2))
7305         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7306      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7307      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7308      &   ADtEA1derx(1,1,1,1,1,2))
7309         ENDIF
7310 C End 6-th order cumulants
7311         call transpose2(EUgder(1,1,l),auxmat(1,1))
7312         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7313         call transpose2(EUg(1,1,l),auxmat(1,1))
7314         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7315         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7316         do iii=1,2
7317           do kkk=1,5
7318             do lll=1,3
7319               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7320      &          EAEAderx(1,1,lll,kkk,iii,2))
7321             enddo
7322           enddo
7323         enddo
7324 C AEAb1 and AEAb2
7325 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7326 C They are needed only when the fifth- or the sixth-order cumulants are
7327 C indluded.
7328         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7329         call transpose2(AEA(1,1,1),auxmat(1,1))
7330         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7331         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7332         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7333         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7334         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7335         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7336         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7337         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7338         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7339         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7340         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7341         call transpose2(AEA(1,1,2),auxmat(1,1))
7342         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7343         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7344         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7345         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7346         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7347         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7348         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7349         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7350         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7351         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7352         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7353 C Calculate the Cartesian derivatives of the vectors.
7354         do iii=1,2
7355           do kkk=1,5
7356             do lll=1,3
7357               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7358               call matvec2(auxmat(1,1),b1(1,iti),
7359      &          AEAb1derx(1,lll,kkk,iii,1,1))
7360               call matvec2(auxmat(1,1),Ub2(1,i),
7361      &          AEAb2derx(1,lll,kkk,iii,1,1))
7362               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7363      &          AEAb1derx(1,lll,kkk,iii,2,1))
7364               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7365      &          AEAb2derx(1,lll,kkk,iii,2,1))
7366               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7367               call matvec2(auxmat(1,1),b1(1,itj),
7368      &          AEAb1derx(1,lll,kkk,iii,1,2))
7369               call matvec2(auxmat(1,1),Ub2(1,j),
7370      &          AEAb2derx(1,lll,kkk,iii,1,2))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7372      &          AEAb1derx(1,lll,kkk,iii,2,2))
7373               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7374      &          AEAb2derx(1,lll,kkk,iii,2,2))
7375             enddo
7376           enddo
7377         enddo
7378         ENDIF
7379 C End vectors
7380       else
7381 C Antiparallel orientation of the two CA-CA-CA frames.
7382         if (i.gt.1) then
7383           iti=itortyp(itype(i))
7384         else
7385           iti=ntortyp+1
7386         endif
7387         itk1=itortyp(itype(k+1))
7388         itl=itortyp(itype(l))
7389         itj=itortyp(itype(j))
7390         if (j.lt.nres-1) then
7391           itj1=itortyp(itype(j+1))
7392         else
7393           itj1=ntortyp+1
7394         endif
7395 C A2 kernel(j-1)T A1T
7396         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7397      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7398      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7399 C Following matrices are needed only for 6-th order cumulants
7400         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7401      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7402         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7403      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7404      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7405         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7406      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7407      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7408      &   ADtEAderx(1,1,1,1,1,1))
7409         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7410      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7411      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7412      &   ADtEA1derx(1,1,1,1,1,1))
7413         ENDIF
7414 C End 6-th order cumulants
7415         call transpose2(EUgder(1,1,k),auxmat(1,1))
7416         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7417         call transpose2(EUg(1,1,k),auxmat(1,1))
7418         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7419         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7420         do iii=1,2
7421           do kkk=1,5
7422             do lll=1,3
7423               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7424      &          EAEAderx(1,1,lll,kkk,iii,1))
7425             enddo
7426           enddo
7427         enddo
7428 C A2T kernel(i+1)T A1
7429         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7430      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7431      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7432 C Following matrices are needed only for 6-th order cumulants
7433         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7434      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7435         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7436      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7437      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7438         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7439      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7440      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7441      &   ADtEAderx(1,1,1,1,1,2))
7442         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7443      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7444      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7445      &   ADtEA1derx(1,1,1,1,1,2))
7446         ENDIF
7447 C End 6-th order cumulants
7448         call transpose2(EUgder(1,1,j),auxmat(1,1))
7449         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7450         call transpose2(EUg(1,1,j),auxmat(1,1))
7451         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7452         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7453         do iii=1,2
7454           do kkk=1,5
7455             do lll=1,3
7456               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7457      &          EAEAderx(1,1,lll,kkk,iii,2))
7458             enddo
7459           enddo
7460         enddo
7461 C AEAb1 and AEAb2
7462 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7463 C They are needed only when the fifth- or the sixth-order cumulants are
7464 C indluded.
7465         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7466      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7467         call transpose2(AEA(1,1,1),auxmat(1,1))
7468         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7469         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7470         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7471         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7472         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7473         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7474         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7475         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7476         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7477         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7478         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7479         call transpose2(AEA(1,1,2),auxmat(1,1))
7480         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7481         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7482         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7483         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7484         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7485         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7486         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7487         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7488         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7489         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7490         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7491 C Calculate the Cartesian derivatives of the vectors.
7492         do iii=1,2
7493           do kkk=1,5
7494             do lll=1,3
7495               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7496               call matvec2(auxmat(1,1),b1(1,iti),
7497      &          AEAb1derx(1,lll,kkk,iii,1,1))
7498               call matvec2(auxmat(1,1),Ub2(1,i),
7499      &          AEAb2derx(1,lll,kkk,iii,1,1))
7500               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7501      &          AEAb1derx(1,lll,kkk,iii,2,1))
7502               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7503      &          AEAb2derx(1,lll,kkk,iii,2,1))
7504               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7505               call matvec2(auxmat(1,1),b1(1,itl),
7506      &          AEAb1derx(1,lll,kkk,iii,1,2))
7507               call matvec2(auxmat(1,1),Ub2(1,l),
7508      &          AEAb2derx(1,lll,kkk,iii,1,2))
7509               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7510      &          AEAb1derx(1,lll,kkk,iii,2,2))
7511               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7512      &          AEAb2derx(1,lll,kkk,iii,2,2))
7513             enddo
7514           enddo
7515         enddo
7516         ENDIF
7517 C End vectors
7518       endif
7519       return
7520       end
7521 C---------------------------------------------------------------------------
7522       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7523      &  KK,KKderg,AKA,AKAderg,AKAderx)
7524       implicit none
7525       integer nderg
7526       logical transp
7527       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7528      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7529      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7530       integer iii,kkk,lll
7531       integer jjj,mmm
7532       logical lprn
7533       common /kutas/ lprn
7534       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7535       do iii=1,nderg
7536         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7537      &    AKAderg(1,1,iii))
7538       enddo
7539 cd      if (lprn) write (2,*) 'In kernel'
7540       do kkk=1,5
7541 cd        if (lprn) write (2,*) 'kkk=',kkk
7542         do lll=1,3
7543           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7544      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7545 cd          if (lprn) then
7546 cd            write (2,*) 'lll=',lll
7547 cd            write (2,*) 'iii=1'
7548 cd            do jjj=1,2
7549 cd              write (2,'(3(2f10.5),5x)')
7550 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7551 cd            enddo
7552 cd          endif
7553           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7554      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7555 cd          if (lprn) then
7556 cd            write (2,*) 'lll=',lll
7557 cd            write (2,*) 'iii=2'
7558 cd            do jjj=1,2
7559 cd              write (2,'(3(2f10.5),5x)')
7560 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7561 cd            enddo
7562 cd          endif
7563         enddo
7564       enddo
7565       return
7566       end
7567 C---------------------------------------------------------------------------
7568       double precision function eello4(i,j,k,l,jj,kk)
7569       implicit real*8 (a-h,o-z)
7570       include 'DIMENSIONS'
7571       include 'COMMON.IOUNITS'
7572       include 'COMMON.CHAIN'
7573       include 'COMMON.DERIV'
7574       include 'COMMON.INTERACT'
7575       include 'COMMON.CONTACTS'
7576       include 'COMMON.TORSION'
7577       include 'COMMON.VAR'
7578       include 'COMMON.GEO'
7579       double precision pizda(2,2),ggg1(3),ggg2(3)
7580 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7581 cd        eello4=0.0d0
7582 cd        return
7583 cd      endif
7584 cd      print *,'eello4:',i,j,k,l,jj,kk
7585 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7586 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7587 cold      eij=facont_hb(jj,i)
7588 cold      ekl=facont_hb(kk,k)
7589 cold      ekont=eij*ekl
7590       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7591 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7592       gcorr_loc(k-1)=gcorr_loc(k-1)
7593      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7594       if (l.eq.j+1) then
7595         gcorr_loc(l-1)=gcorr_loc(l-1)
7596      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7597       else
7598         gcorr_loc(j-1)=gcorr_loc(j-1)
7599      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7600       endif
7601       do iii=1,2
7602         do kkk=1,5
7603           do lll=1,3
7604             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7605      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7606 cd            derx(lll,kkk,iii)=0.0d0
7607           enddo
7608         enddo
7609       enddo
7610 cd      gcorr_loc(l-1)=0.0d0
7611 cd      gcorr_loc(j-1)=0.0d0
7612 cd      gcorr_loc(k-1)=0.0d0
7613 cd      eel4=1.0d0
7614 cd      write (iout,*)'Contacts have occurred for peptide groups',
7615 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7616 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7617       if (j.lt.nres-1) then
7618         j1=j+1
7619         j2=j-1
7620       else
7621         j1=j-1
7622         j2=j-2
7623       endif
7624       if (l.lt.nres-1) then
7625         l1=l+1
7626         l2=l-1
7627       else
7628         l1=l-1
7629         l2=l-2
7630       endif
7631       do ll=1,3
7632 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7633 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7634         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7635         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7636 cgrad        ghalf=0.5d0*ggg1(ll)
7637         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7638         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7639         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7640         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7641         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7642         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7643 cgrad        ghalf=0.5d0*ggg2(ll)
7644         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7645         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7646         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7647         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7648         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7649         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7650       enddo
7651 cgrad      do m=i+1,j-1
7652 cgrad        do ll=1,3
7653 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7654 cgrad        enddo
7655 cgrad      enddo
7656 cgrad      do m=k+1,l-1
7657 cgrad        do ll=1,3
7658 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7659 cgrad        enddo
7660 cgrad      enddo
7661 cgrad      do m=i+2,j2
7662 cgrad        do ll=1,3
7663 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7664 cgrad        enddo
7665 cgrad      enddo
7666 cgrad      do m=k+2,l2
7667 cgrad        do ll=1,3
7668 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7669 cgrad        enddo
7670 cgrad      enddo
7671 cd      do iii=1,nres-3
7672 cd        write (2,*) iii,gcorr_loc(iii)
7673 cd      enddo
7674       eello4=ekont*eel4
7675 cd      write (2,*) 'ekont',ekont
7676 cd      write (iout,*) 'eello4',ekont*eel4
7677       return
7678       end
7679 C---------------------------------------------------------------------------
7680       double precision function eello5(i,j,k,l,jj,kk)
7681       implicit real*8 (a-h,o-z)
7682       include 'DIMENSIONS'
7683       include 'COMMON.IOUNITS'
7684       include 'COMMON.CHAIN'
7685       include 'COMMON.DERIV'
7686       include 'COMMON.INTERACT'
7687       include 'COMMON.CONTACTS'
7688       include 'COMMON.TORSION'
7689       include 'COMMON.VAR'
7690       include 'COMMON.GEO'
7691       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7692       double precision ggg1(3),ggg2(3)
7693 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7694 C                                                                              C
7695 C                            Parallel chains                                   C
7696 C                                                                              C
7697 C          o             o                   o             o                   C
7698 C         /l\           / \             \   / \           / \   /              C
7699 C        /   \         /   \             \ /   \         /   \ /               C
7700 C       j| o |l1       | o |              o| o |         | o |o                C
7701 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7702 C      \i/   \         /   \ /             /   \         /   \                 C
7703 C       o    k1             o                                                  C
7704 C         (I)          (II)                (III)          (IV)                 C
7705 C                                                                              C
7706 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7707 C                                                                              C
7708 C                            Antiparallel chains                               C
7709 C                                                                              C
7710 C          o             o                   o             o                   C
7711 C         /j\           / \             \   / \           / \   /              C
7712 C        /   \         /   \             \ /   \         /   \ /               C
7713 C      j1| o |l        | o |              o| o |         | o |o                C
7714 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7715 C      \i/   \         /   \ /             /   \         /   \                 C
7716 C       o     k1            o                                                  C
7717 C         (I)          (II)                (III)          (IV)                 C
7718 C                                                                              C
7719 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7720 C                                                                              C
7721 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7722 C                                                                              C
7723 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7724 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7725 cd        eello5=0.0d0
7726 cd        return
7727 cd      endif
7728 cd      write (iout,*)
7729 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7730 cd     &   ' and',k,l
7731       itk=itortyp(itype(k))
7732       itl=itortyp(itype(l))
7733       itj=itortyp(itype(j))
7734       eello5_1=0.0d0
7735       eello5_2=0.0d0
7736       eello5_3=0.0d0
7737       eello5_4=0.0d0
7738 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7739 cd     &   eel5_3_num,eel5_4_num)
7740       do iii=1,2
7741         do kkk=1,5
7742           do lll=1,3
7743             derx(lll,kkk,iii)=0.0d0
7744           enddo
7745         enddo
7746       enddo
7747 cd      eij=facont_hb(jj,i)
7748 cd      ekl=facont_hb(kk,k)
7749 cd      ekont=eij*ekl
7750 cd      write (iout,*)'Contacts have occurred for peptide groups',
7751 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7752 cd      goto 1111
7753 C Contribution from the graph I.
7754 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7755 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7756       call transpose2(EUg(1,1,k),auxmat(1,1))
7757       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7758       vv(1)=pizda(1,1)-pizda(2,2)
7759       vv(2)=pizda(1,2)+pizda(2,1)
7760       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7761      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7762 C Explicit gradient in virtual-dihedral angles.
7763       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7764      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7765      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7766       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7767       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7768       vv(1)=pizda(1,1)-pizda(2,2)
7769       vv(2)=pizda(1,2)+pizda(2,1)
7770       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7771      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7772      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7773       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7774       vv(1)=pizda(1,1)-pizda(2,2)
7775       vv(2)=pizda(1,2)+pizda(2,1)
7776       if (l.eq.j+1) then
7777         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7778      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7779      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7780       else
7781         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7782      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7783      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7784       endif
7785 C Cartesian gradient
7786       do iii=1,2
7787         do kkk=1,5
7788           do lll=1,3
7789             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7790      &        pizda(1,1))
7791             vv(1)=pizda(1,1)-pizda(2,2)
7792             vv(2)=pizda(1,2)+pizda(2,1)
7793             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7794      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7795      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7796           enddo
7797         enddo
7798       enddo
7799 c      goto 1112
7800 c1111  continue
7801 C Contribution from graph II
7802       call transpose2(EE(1,1,itk),auxmat(1,1))
7803       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7804       vv(1)=pizda(1,1)+pizda(2,2)
7805       vv(2)=pizda(2,1)-pizda(1,2)
7806       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7807      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7808 C Explicit gradient in virtual-dihedral angles.
7809       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7810      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7811       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7812       vv(1)=pizda(1,1)+pizda(2,2)
7813       vv(2)=pizda(2,1)-pizda(1,2)
7814       if (l.eq.j+1) then
7815         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7816      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7817      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7818       else
7819         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7820      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7821      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7822       endif
7823 C Cartesian gradient
7824       do iii=1,2
7825         do kkk=1,5
7826           do lll=1,3
7827             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7828      &        pizda(1,1))
7829             vv(1)=pizda(1,1)+pizda(2,2)
7830             vv(2)=pizda(2,1)-pizda(1,2)
7831             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7832      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7833      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7834           enddo
7835         enddo
7836       enddo
7837 cd      goto 1112
7838 cd1111  continue
7839       if (l.eq.j+1) then
7840 cd        goto 1110
7841 C Parallel orientation
7842 C Contribution from graph III
7843         call transpose2(EUg(1,1,l),auxmat(1,1))
7844         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7845         vv(1)=pizda(1,1)-pizda(2,2)
7846         vv(2)=pizda(1,2)+pizda(2,1)
7847         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7848      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7849 C Explicit gradient in virtual-dihedral angles.
7850         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7851      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7852      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7853         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7854         vv(1)=pizda(1,1)-pizda(2,2)
7855         vv(2)=pizda(1,2)+pizda(2,1)
7856         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7857      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7858      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7859         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7860         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7861         vv(1)=pizda(1,1)-pizda(2,2)
7862         vv(2)=pizda(1,2)+pizda(2,1)
7863         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7864      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7865      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7866 C Cartesian gradient
7867         do iii=1,2
7868           do kkk=1,5
7869             do lll=1,3
7870               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7871      &          pizda(1,1))
7872               vv(1)=pizda(1,1)-pizda(2,2)
7873               vv(2)=pizda(1,2)+pizda(2,1)
7874               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7875      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7876      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7877             enddo
7878           enddo
7879         enddo
7880 cd        goto 1112
7881 C Contribution from graph IV
7882 cd1110    continue
7883         call transpose2(EE(1,1,itl),auxmat(1,1))
7884         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7885         vv(1)=pizda(1,1)+pizda(2,2)
7886         vv(2)=pizda(2,1)-pizda(1,2)
7887         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7888      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7889 C Explicit gradient in virtual-dihedral angles.
7890         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7891      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7892         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7893         vv(1)=pizda(1,1)+pizda(2,2)
7894         vv(2)=pizda(2,1)-pizda(1,2)
7895         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7896      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7897      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7898 C Cartesian gradient
7899         do iii=1,2
7900           do kkk=1,5
7901             do lll=1,3
7902               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7903      &          pizda(1,1))
7904               vv(1)=pizda(1,1)+pizda(2,2)
7905               vv(2)=pizda(2,1)-pizda(1,2)
7906               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7907      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7908      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7909             enddo
7910           enddo
7911         enddo
7912       else
7913 C Antiparallel orientation
7914 C Contribution from graph III
7915 c        goto 1110
7916         call transpose2(EUg(1,1,j),auxmat(1,1))
7917         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7918         vv(1)=pizda(1,1)-pizda(2,2)
7919         vv(2)=pizda(1,2)+pizda(2,1)
7920         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7921      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7922 C Explicit gradient in virtual-dihedral angles.
7923         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7924      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7925      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7926         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7927         vv(1)=pizda(1,1)-pizda(2,2)
7928         vv(2)=pizda(1,2)+pizda(2,1)
7929         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7930      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7931      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7932         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7933         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7934         vv(1)=pizda(1,1)-pizda(2,2)
7935         vv(2)=pizda(1,2)+pizda(2,1)
7936         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7937      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7938      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7939 C Cartesian gradient
7940         do iii=1,2
7941           do kkk=1,5
7942             do lll=1,3
7943               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7944      &          pizda(1,1))
7945               vv(1)=pizda(1,1)-pizda(2,2)
7946               vv(2)=pizda(1,2)+pizda(2,1)
7947               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7948      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7949      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7950             enddo
7951           enddo
7952         enddo
7953 cd        goto 1112
7954 C Contribution from graph IV
7955 1110    continue
7956         call transpose2(EE(1,1,itj),auxmat(1,1))
7957         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7958         vv(1)=pizda(1,1)+pizda(2,2)
7959         vv(2)=pizda(2,1)-pizda(1,2)
7960         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7961      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7962 C Explicit gradient in virtual-dihedral angles.
7963         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7964      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7965         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7966         vv(1)=pizda(1,1)+pizda(2,2)
7967         vv(2)=pizda(2,1)-pizda(1,2)
7968         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7969      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7970      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7971 C Cartesian gradient
7972         do iii=1,2
7973           do kkk=1,5
7974             do lll=1,3
7975               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7976      &          pizda(1,1))
7977               vv(1)=pizda(1,1)+pizda(2,2)
7978               vv(2)=pizda(2,1)-pizda(1,2)
7979               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7980      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7981      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7982             enddo
7983           enddo
7984         enddo
7985       endif
7986 1112  continue
7987       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7988 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7989 cd        write (2,*) 'ijkl',i,j,k,l
7990 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7991 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7992 cd      endif
7993 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7994 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7995 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7996 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7997       if (j.lt.nres-1) then
7998         j1=j+1
7999         j2=j-1
8000       else
8001         j1=j-1
8002         j2=j-2
8003       endif
8004       if (l.lt.nres-1) then
8005         l1=l+1
8006         l2=l-1
8007       else
8008         l1=l-1
8009         l2=l-2
8010       endif
8011 cd      eij=1.0d0
8012 cd      ekl=1.0d0
8013 cd      ekont=1.0d0
8014 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8015 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8016 C        summed up outside the subrouine as for the other subroutines
8017 C        handling long-range interactions. The old code is commented out
8018 C        with "cgrad" to keep track of changes.
8019       do ll=1,3
8020 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8021 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8022         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8023         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8024 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8025 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8026 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8027 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8028 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8029 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8030 c     &   gradcorr5ij,
8031 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8032 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8033 cgrad        ghalf=0.5d0*ggg1(ll)
8034 cd        ghalf=0.0d0
8035         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8036         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8037         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8038         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8039         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8040         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8041 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8042 cgrad        ghalf=0.5d0*ggg2(ll)
8043 cd        ghalf=0.0d0
8044         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8045         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8046         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8047         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8048         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8049         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8050       enddo
8051 cd      goto 1112
8052 cgrad      do m=i+1,j-1
8053 cgrad        do ll=1,3
8054 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8055 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8056 cgrad        enddo
8057 cgrad      enddo
8058 cgrad      do m=k+1,l-1
8059 cgrad        do ll=1,3
8060 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8061 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8062 cgrad        enddo
8063 cgrad      enddo
8064 c1112  continue
8065 cgrad      do m=i+2,j2
8066 cgrad        do ll=1,3
8067 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8068 cgrad        enddo
8069 cgrad      enddo
8070 cgrad      do m=k+2,l2
8071 cgrad        do ll=1,3
8072 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8073 cgrad        enddo
8074 cgrad      enddo
8075 cd      do iii=1,nres-3
8076 cd        write (2,*) iii,g_corr5_loc(iii)
8077 cd      enddo
8078       eello5=ekont*eel5
8079 cd      write (2,*) 'ekont',ekont
8080 cd      write (iout,*) 'eello5',ekont*eel5
8081       return
8082       end
8083 c--------------------------------------------------------------------------
8084       double precision function eello6(i,j,k,l,jj,kk)
8085       implicit real*8 (a-h,o-z)
8086       include 'DIMENSIONS'
8087       include 'COMMON.IOUNITS'
8088       include 'COMMON.CHAIN'
8089       include 'COMMON.DERIV'
8090       include 'COMMON.INTERACT'
8091       include 'COMMON.CONTACTS'
8092       include 'COMMON.TORSION'
8093       include 'COMMON.VAR'
8094       include 'COMMON.GEO'
8095       include 'COMMON.FFIELD'
8096       double precision ggg1(3),ggg2(3)
8097 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8098 cd        eello6=0.0d0
8099 cd        return
8100 cd      endif
8101 cd      write (iout,*)
8102 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8103 cd     &   ' and',k,l
8104       eello6_1=0.0d0
8105       eello6_2=0.0d0
8106       eello6_3=0.0d0
8107       eello6_4=0.0d0
8108       eello6_5=0.0d0
8109       eello6_6=0.0d0
8110 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8111 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8112       do iii=1,2
8113         do kkk=1,5
8114           do lll=1,3
8115             derx(lll,kkk,iii)=0.0d0
8116           enddo
8117         enddo
8118       enddo
8119 cd      eij=facont_hb(jj,i)
8120 cd      ekl=facont_hb(kk,k)
8121 cd      ekont=eij*ekl
8122 cd      eij=1.0d0
8123 cd      ekl=1.0d0
8124 cd      ekont=1.0d0
8125       if (l.eq.j+1) then
8126         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8127         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8128         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8129         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8130         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8131         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8132       else
8133         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8134         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8135         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8136         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8137         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8138           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8139         else
8140           eello6_5=0.0d0
8141         endif
8142         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8143       endif
8144 C If turn contributions are considered, they will be handled separately.
8145       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8146 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8147 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8148 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8149 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8150 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8151 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8152 cd      goto 1112
8153       if (j.lt.nres-1) then
8154         j1=j+1
8155         j2=j-1
8156       else
8157         j1=j-1
8158         j2=j-2
8159       endif
8160       if (l.lt.nres-1) then
8161         l1=l+1
8162         l2=l-1
8163       else
8164         l1=l-1
8165         l2=l-2
8166       endif
8167       do ll=1,3
8168 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8169 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8170 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8171 cgrad        ghalf=0.5d0*ggg1(ll)
8172 cd        ghalf=0.0d0
8173         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8174         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8175         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8176         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8177         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8178         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8179         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8180         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8181 cgrad        ghalf=0.5d0*ggg2(ll)
8182 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8183 cd        ghalf=0.0d0
8184         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8185         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8186         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8187         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8188         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8189         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8190       enddo
8191 cd      goto 1112
8192 cgrad      do m=i+1,j-1
8193 cgrad        do ll=1,3
8194 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8195 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8196 cgrad        enddo
8197 cgrad      enddo
8198 cgrad      do m=k+1,l-1
8199 cgrad        do ll=1,3
8200 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8201 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8202 cgrad        enddo
8203 cgrad      enddo
8204 cgrad1112  continue
8205 cgrad      do m=i+2,j2
8206 cgrad        do ll=1,3
8207 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8208 cgrad        enddo
8209 cgrad      enddo
8210 cgrad      do m=k+2,l2
8211 cgrad        do ll=1,3
8212 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8213 cgrad        enddo
8214 cgrad      enddo
8215 cd      do iii=1,nres-3
8216 cd        write (2,*) iii,g_corr6_loc(iii)
8217 cd      enddo
8218       eello6=ekont*eel6
8219 cd      write (2,*) 'ekont',ekont
8220 cd      write (iout,*) 'eello6',ekont*eel6
8221       return
8222       end
8223 c--------------------------------------------------------------------------
8224       double precision function eello6_graph1(i,j,k,l,imat,swap)
8225       implicit real*8 (a-h,o-z)
8226       include 'DIMENSIONS'
8227       include 'COMMON.IOUNITS'
8228       include 'COMMON.CHAIN'
8229       include 'COMMON.DERIV'
8230       include 'COMMON.INTERACT'
8231       include 'COMMON.CONTACTS'
8232       include 'COMMON.TORSION'
8233       include 'COMMON.VAR'
8234       include 'COMMON.GEO'
8235       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8236       logical swap
8237       logical lprn
8238       common /kutas/ lprn
8239 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8240 C                                                                              C
8241 C      Parallel       Antiparallel                                             C
8242 C                                                                              C
8243 C          o             o                                                     C
8244 C         /l\           /j\                                                    C
8245 C        /   \         /   \                                                   C
8246 C       /| o |         | o |\                                                  C
8247 C     \ j|/k\|  /   \  |/k\|l /                                                C
8248 C      \ /   \ /     \ /   \ /                                                 C
8249 C       o     o       o     o                                                  C
8250 C       i             i                                                        C
8251 C                                                                              C
8252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8253       itk=itortyp(itype(k))
8254       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8255       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8256       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8257       call transpose2(EUgC(1,1,k),auxmat(1,1))
8258       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8259       vv1(1)=pizda1(1,1)-pizda1(2,2)
8260       vv1(2)=pizda1(1,2)+pizda1(2,1)
8261       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8262       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8263       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8264       s5=scalar2(vv(1),Dtobr2(1,i))
8265 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8266       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8267       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8268      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8269      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8270      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8271      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8272      & +scalar2(vv(1),Dtobr2der(1,i)))
8273       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8274       vv1(1)=pizda1(1,1)-pizda1(2,2)
8275       vv1(2)=pizda1(1,2)+pizda1(2,1)
8276       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8277       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8278       if (l.eq.j+1) then
8279         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8280      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8281      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8282      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8283      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8284       else
8285         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8286      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8287      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8288      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8289      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8290       endif
8291       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8292       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8293       vv1(1)=pizda1(1,1)-pizda1(2,2)
8294       vv1(2)=pizda1(1,2)+pizda1(2,1)
8295       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8296      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8297      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8298      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8299       do iii=1,2
8300         if (swap) then
8301           ind=3-iii
8302         else
8303           ind=iii
8304         endif
8305         do kkk=1,5
8306           do lll=1,3
8307             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8308             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8309             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8310             call transpose2(EUgC(1,1,k),auxmat(1,1))
8311             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8312      &        pizda1(1,1))
8313             vv1(1)=pizda1(1,1)-pizda1(2,2)
8314             vv1(2)=pizda1(1,2)+pizda1(2,1)
8315             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8316             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8317      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8318             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8319      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8320             s5=scalar2(vv(1),Dtobr2(1,i))
8321             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8322           enddo
8323         enddo
8324       enddo
8325       return
8326       end
8327 c----------------------------------------------------------------------------
8328       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8329       implicit real*8 (a-h,o-z)
8330       include 'DIMENSIONS'
8331       include 'COMMON.IOUNITS'
8332       include 'COMMON.CHAIN'
8333       include 'COMMON.DERIV'
8334       include 'COMMON.INTERACT'
8335       include 'COMMON.CONTACTS'
8336       include 'COMMON.TORSION'
8337       include 'COMMON.VAR'
8338       include 'COMMON.GEO'
8339       logical swap
8340       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8341      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8342       logical lprn
8343       common /kutas/ lprn
8344 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8345 C                                                                              C
8346 C      Parallel       Antiparallel                                             C
8347 C                                                                              C
8348 C          o             o                                                     C
8349 C     \   /l\           /j\   /                                                C
8350 C      \ /   \         /   \ /                                                 C
8351 C       o| o |         | o |o                                                  C
8352 C     \ j|/k\|      \  |/k\|l                                                  C
8353 C      \ /   \       \ /   \                                                   C
8354 C       o             o                                                        C
8355 C       i             i                                                        C
8356 C                                                                              C
8357 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8358 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8359 C AL 7/4/01 s1 would occur in the sixth-order moment,
8360 C           but not in a cluster cumulant
8361 #ifdef MOMENT
8362       s1=dip(1,jj,i)*dip(1,kk,k)
8363 #endif
8364       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8365       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8366       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8367       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8368       call transpose2(EUg(1,1,k),auxmat(1,1))
8369       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8370       vv(1)=pizda(1,1)-pizda(2,2)
8371       vv(2)=pizda(1,2)+pizda(2,1)
8372       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8373 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8374 #ifdef MOMENT
8375       eello6_graph2=-(s1+s2+s3+s4)
8376 #else
8377       eello6_graph2=-(s2+s3+s4)
8378 #endif
8379 c      eello6_graph2=-s3
8380 C Derivatives in gamma(i-1)
8381       if (i.gt.1) then
8382 #ifdef MOMENT
8383         s1=dipderg(1,jj,i)*dip(1,kk,k)
8384 #endif
8385         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8386         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8387         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8388         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8389 #ifdef MOMENT
8390         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8391 #else
8392         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8393 #endif
8394 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8395       endif
8396 C Derivatives in gamma(k-1)
8397 #ifdef MOMENT
8398       s1=dip(1,jj,i)*dipderg(1,kk,k)
8399 #endif
8400       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8401       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8402       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8403       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8404       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8405       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8406       vv(1)=pizda(1,1)-pizda(2,2)
8407       vv(2)=pizda(1,2)+pizda(2,1)
8408       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8409 #ifdef MOMENT
8410       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8411 #else
8412       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8413 #endif
8414 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8415 C Derivatives in gamma(j-1) or gamma(l-1)
8416       if (j.gt.1) then
8417 #ifdef MOMENT
8418         s1=dipderg(3,jj,i)*dip(1,kk,k)
8419 #endif
8420         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8421         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8422         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8423         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8424         vv(1)=pizda(1,1)-pizda(2,2)
8425         vv(2)=pizda(1,2)+pizda(2,1)
8426         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8427 #ifdef MOMENT
8428         if (swap) then
8429           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8430         else
8431           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8432         endif
8433 #endif
8434         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8435 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8436       endif
8437 C Derivatives in gamma(l-1) or gamma(j-1)
8438       if (l.gt.1) then
8439 #ifdef MOMENT
8440         s1=dip(1,jj,i)*dipderg(3,kk,k)
8441 #endif
8442         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8443         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8444         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8445         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8446         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8447         vv(1)=pizda(1,1)-pizda(2,2)
8448         vv(2)=pizda(1,2)+pizda(2,1)
8449         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8450 #ifdef MOMENT
8451         if (swap) then
8452           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8453         else
8454           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8455         endif
8456 #endif
8457         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8458 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8459       endif
8460 C Cartesian derivatives.
8461       if (lprn) then
8462         write (2,*) 'In eello6_graph2'
8463         do iii=1,2
8464           write (2,*) 'iii=',iii
8465           do kkk=1,5
8466             write (2,*) 'kkk=',kkk
8467             do jjj=1,2
8468               write (2,'(3(2f10.5),5x)')
8469      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8470             enddo
8471           enddo
8472         enddo
8473       endif
8474       do iii=1,2
8475         do kkk=1,5
8476           do lll=1,3
8477 #ifdef MOMENT
8478             if (iii.eq.1) then
8479               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8480             else
8481               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8482             endif
8483 #endif
8484             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8485      &        auxvec(1))
8486             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8487             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8488      &        auxvec(1))
8489             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8490             call transpose2(EUg(1,1,k),auxmat(1,1))
8491             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8492      &        pizda(1,1))
8493             vv(1)=pizda(1,1)-pizda(2,2)
8494             vv(2)=pizda(1,2)+pizda(2,1)
8495             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8496 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8497 #ifdef MOMENT
8498             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8499 #else
8500             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8501 #endif
8502             if (swap) then
8503               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8504             else
8505               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8506             endif
8507           enddo
8508         enddo
8509       enddo
8510       return
8511       end
8512 c----------------------------------------------------------------------------
8513       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8514       implicit real*8 (a-h,o-z)
8515       include 'DIMENSIONS'
8516       include 'COMMON.IOUNITS'
8517       include 'COMMON.CHAIN'
8518       include 'COMMON.DERIV'
8519       include 'COMMON.INTERACT'
8520       include 'COMMON.CONTACTS'
8521       include 'COMMON.TORSION'
8522       include 'COMMON.VAR'
8523       include 'COMMON.GEO'
8524       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8525       logical swap
8526 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8527 C                                                                              C
8528 C      Parallel       Antiparallel                                             C
8529 C                                                                              C
8530 C          o             o                                                     C
8531 C         /l\   /   \   /j\                                                    C
8532 C        /   \ /     \ /   \                                                   C
8533 C       /| o |o       o| o |\                                                  C
8534 C       j|/k\|  /      |/k\|l /                                                C
8535 C        /   \ /       /   \ /                                                 C
8536 C       /     o       /     o                                                  C
8537 C       i             i                                                        C
8538 C                                                                              C
8539 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8540 C
8541 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8542 C           energy moment and not to the cluster cumulant.
8543       iti=itortyp(itype(i))
8544       if (j.lt.nres-1) then
8545         itj1=itortyp(itype(j+1))
8546       else
8547         itj1=ntortyp+1
8548       endif
8549       itk=itortyp(itype(k))
8550       itk1=itortyp(itype(k+1))
8551       if (l.lt.nres-1) then
8552         itl1=itortyp(itype(l+1))
8553       else
8554         itl1=ntortyp+1
8555       endif
8556 #ifdef MOMENT
8557       s1=dip(4,jj,i)*dip(4,kk,k)
8558 #endif
8559       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8560       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8561       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8562       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8563       call transpose2(EE(1,1,itk),auxmat(1,1))
8564       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8565       vv(1)=pizda(1,1)+pizda(2,2)
8566       vv(2)=pizda(2,1)-pizda(1,2)
8567       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8568 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8569 cd     & "sum",-(s2+s3+s4)
8570 #ifdef MOMENT
8571       eello6_graph3=-(s1+s2+s3+s4)
8572 #else
8573       eello6_graph3=-(s2+s3+s4)
8574 #endif
8575 c      eello6_graph3=-s4
8576 C Derivatives in gamma(k-1)
8577       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8578       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8579       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8580       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8581 C Derivatives in gamma(l-1)
8582       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8583       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8584       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8585       vv(1)=pizda(1,1)+pizda(2,2)
8586       vv(2)=pizda(2,1)-pizda(1,2)
8587       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8588       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8589 C Cartesian derivatives.
8590       do iii=1,2
8591         do kkk=1,5
8592           do lll=1,3
8593 #ifdef MOMENT
8594             if (iii.eq.1) then
8595               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8596             else
8597               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8598             endif
8599 #endif
8600             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8601      &        auxvec(1))
8602             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8603             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8604      &        auxvec(1))
8605             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8606             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8607      &        pizda(1,1))
8608             vv(1)=pizda(1,1)+pizda(2,2)
8609             vv(2)=pizda(2,1)-pizda(1,2)
8610             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8611 #ifdef MOMENT
8612             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8613 #else
8614             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8615 #endif
8616             if (swap) then
8617               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8618             else
8619               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8620             endif
8621 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8622           enddo
8623         enddo
8624       enddo
8625       return
8626       end
8627 c----------------------------------------------------------------------------
8628       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8629       implicit real*8 (a-h,o-z)
8630       include 'DIMENSIONS'
8631       include 'COMMON.IOUNITS'
8632       include 'COMMON.CHAIN'
8633       include 'COMMON.DERIV'
8634       include 'COMMON.INTERACT'
8635       include 'COMMON.CONTACTS'
8636       include 'COMMON.TORSION'
8637       include 'COMMON.VAR'
8638       include 'COMMON.GEO'
8639       include 'COMMON.FFIELD'
8640       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8641      & auxvec1(2),auxmat1(2,2)
8642       logical swap
8643 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8644 C                                                                              C
8645 C      Parallel       Antiparallel                                             C
8646 C                                                                              C
8647 C          o             o                                                     C
8648 C         /l\   /   \   /j\                                                    C
8649 C        /   \ /     \ /   \                                                   C
8650 C       /| o |o       o| o |\                                                  C
8651 C     \ j|/k\|      \  |/k\|l                                                  C
8652 C      \ /   \       \ /   \                                                   C
8653 C       o     \       o     \                                                  C
8654 C       i             i                                                        C
8655 C                                                                              C
8656 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8657 C
8658 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8659 C           energy moment and not to the cluster cumulant.
8660 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8661       iti=itortyp(itype(i))
8662       itj=itortyp(itype(j))
8663       if (j.lt.nres-1) then
8664         itj1=itortyp(itype(j+1))
8665       else
8666         itj1=ntortyp+1
8667       endif
8668       itk=itortyp(itype(k))
8669       if (k.lt.nres-1) then
8670         itk1=itortyp(itype(k+1))
8671       else
8672         itk1=ntortyp+1
8673       endif
8674       itl=itortyp(itype(l))
8675       if (l.lt.nres-1) then
8676         itl1=itortyp(itype(l+1))
8677       else
8678         itl1=ntortyp+1
8679       endif
8680 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8681 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8682 cd     & ' itl',itl,' itl1',itl1
8683 #ifdef MOMENT
8684       if (imat.eq.1) then
8685         s1=dip(3,jj,i)*dip(3,kk,k)
8686       else
8687         s1=dip(2,jj,j)*dip(2,kk,l)
8688       endif
8689 #endif
8690       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8691       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8692       if (j.eq.l+1) then
8693         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8694         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8695       else
8696         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8697         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8698       endif
8699       call transpose2(EUg(1,1,k),auxmat(1,1))
8700       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8701       vv(1)=pizda(1,1)-pizda(2,2)
8702       vv(2)=pizda(2,1)+pizda(1,2)
8703       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8704 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8705 #ifdef MOMENT
8706       eello6_graph4=-(s1+s2+s3+s4)
8707 #else
8708       eello6_graph4=-(s2+s3+s4)
8709 #endif
8710 C Derivatives in gamma(i-1)
8711       if (i.gt.1) then
8712 #ifdef MOMENT
8713         if (imat.eq.1) then
8714           s1=dipderg(2,jj,i)*dip(3,kk,k)
8715         else
8716           s1=dipderg(4,jj,j)*dip(2,kk,l)
8717         endif
8718 #endif
8719         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8720         if (j.eq.l+1) then
8721           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8722           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8723         else
8724           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8725           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8726         endif
8727         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8728         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8729 cd          write (2,*) 'turn6 derivatives'
8730 #ifdef MOMENT
8731           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8732 #else
8733           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8734 #endif
8735         else
8736 #ifdef MOMENT
8737           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8738 #else
8739           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8740 #endif
8741         endif
8742       endif
8743 C Derivatives in gamma(k-1)
8744 #ifdef MOMENT
8745       if (imat.eq.1) then
8746         s1=dip(3,jj,i)*dipderg(2,kk,k)
8747       else
8748         s1=dip(2,jj,j)*dipderg(4,kk,l)
8749       endif
8750 #endif
8751       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8752       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8753       if (j.eq.l+1) then
8754         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8755         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8756       else
8757         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8758         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8759       endif
8760       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8761       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8762       vv(1)=pizda(1,1)-pizda(2,2)
8763       vv(2)=pizda(2,1)+pizda(1,2)
8764       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8765       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8766 #ifdef MOMENT
8767         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8768 #else
8769         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8770 #endif
8771       else
8772 #ifdef MOMENT
8773         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8774 #else
8775         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8776 #endif
8777       endif
8778 C Derivatives in gamma(j-1) or gamma(l-1)
8779       if (l.eq.j+1 .and. l.gt.1) then
8780         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8781         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8782         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8783         vv(1)=pizda(1,1)-pizda(2,2)
8784         vv(2)=pizda(2,1)+pizda(1,2)
8785         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8786         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8787       else if (j.gt.1) then
8788         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8789         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8790         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8791         vv(1)=pizda(1,1)-pizda(2,2)
8792         vv(2)=pizda(2,1)+pizda(1,2)
8793         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8794         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8795           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8796         else
8797           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8798         endif
8799       endif
8800 C Cartesian derivatives.
8801       do iii=1,2
8802         do kkk=1,5
8803           do lll=1,3
8804 #ifdef MOMENT
8805             if (iii.eq.1) then
8806               if (imat.eq.1) then
8807                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8808               else
8809                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8810               endif
8811             else
8812               if (imat.eq.1) then
8813                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8814               else
8815                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8816               endif
8817             endif
8818 #endif
8819             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8820      &        auxvec(1))
8821             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8822             if (j.eq.l+1) then
8823               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8824      &          b1(1,itj1),auxvec(1))
8825               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8826             else
8827               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8828      &          b1(1,itl1),auxvec(1))
8829               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8830             endif
8831             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8832      &        pizda(1,1))
8833             vv(1)=pizda(1,1)-pizda(2,2)
8834             vv(2)=pizda(2,1)+pizda(1,2)
8835             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8836             if (swap) then
8837               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8838 #ifdef MOMENT
8839                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8840      &             -(s1+s2+s4)
8841 #else
8842                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8843      &             -(s2+s4)
8844 #endif
8845                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8846               else
8847 #ifdef MOMENT
8848                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8849 #else
8850                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8851 #endif
8852                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8853               endif
8854             else
8855 #ifdef MOMENT
8856               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8857 #else
8858               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8859 #endif
8860               if (l.eq.j+1) then
8861                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8862               else
8863                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8864               endif
8865             endif
8866           enddo
8867         enddo
8868       enddo
8869       return
8870       end
8871 c----------------------------------------------------------------------------
8872       double precision function eello_turn6(i,jj,kk)
8873       implicit real*8 (a-h,o-z)
8874       include 'DIMENSIONS'
8875       include 'COMMON.IOUNITS'
8876       include 'COMMON.CHAIN'
8877       include 'COMMON.DERIV'
8878       include 'COMMON.INTERACT'
8879       include 'COMMON.CONTACTS'
8880       include 'COMMON.TORSION'
8881       include 'COMMON.VAR'
8882       include 'COMMON.GEO'
8883       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8884      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8885      &  ggg1(3),ggg2(3)
8886       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8887      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8888 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8889 C           the respective energy moment and not to the cluster cumulant.
8890       s1=0.0d0
8891       s8=0.0d0
8892       s13=0.0d0
8893 c
8894       eello_turn6=0.0d0
8895       j=i+4
8896       k=i+1
8897       l=i+3
8898       iti=itortyp(itype(i))
8899       itk=itortyp(itype(k))
8900       itk1=itortyp(itype(k+1))
8901       itl=itortyp(itype(l))
8902       itj=itortyp(itype(j))
8903 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8904 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8905 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8906 cd        eello6=0.0d0
8907 cd        return
8908 cd      endif
8909 cd      write (iout,*)
8910 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8911 cd     &   ' and',k,l
8912 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8913       do iii=1,2
8914         do kkk=1,5
8915           do lll=1,3
8916             derx_turn(lll,kkk,iii)=0.0d0
8917           enddo
8918         enddo
8919       enddo
8920 cd      eij=1.0d0
8921 cd      ekl=1.0d0
8922 cd      ekont=1.0d0
8923       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8924 cd      eello6_5=0.0d0
8925 cd      write (2,*) 'eello6_5',eello6_5
8926 #ifdef MOMENT
8927       call transpose2(AEA(1,1,1),auxmat(1,1))
8928       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8929       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8930       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8931 #endif
8932       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8933       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8934       s2 = scalar2(b1(1,itk),vtemp1(1))
8935 #ifdef MOMENT
8936       call transpose2(AEA(1,1,2),atemp(1,1))
8937       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8938       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8939       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8940 #endif
8941       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8942       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8943       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8944 #ifdef MOMENT
8945       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8946       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8947       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8948       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8949       ss13 = scalar2(b1(1,itk),vtemp4(1))
8950       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8951 #endif
8952 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8953 c      s1=0.0d0
8954 c      s2=0.0d0
8955 c      s8=0.0d0
8956 c      s12=0.0d0
8957 c      s13=0.0d0
8958       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8959 C Derivatives in gamma(i+2)
8960       s1d =0.0d0
8961       s8d =0.0d0
8962 #ifdef MOMENT
8963       call transpose2(AEA(1,1,1),auxmatd(1,1))
8964       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8965       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8966       call transpose2(AEAderg(1,1,2),atempd(1,1))
8967       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8968       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8969 #endif
8970       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8971       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8972       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8973 c      s1d=0.0d0
8974 c      s2d=0.0d0
8975 c      s8d=0.0d0
8976 c      s12d=0.0d0
8977 c      s13d=0.0d0
8978       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8979 C Derivatives in gamma(i+3)
8980 #ifdef MOMENT
8981       call transpose2(AEA(1,1,1),auxmatd(1,1))
8982       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8983       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8984       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8985 #endif
8986       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8987       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8988       s2d = scalar2(b1(1,itk),vtemp1d(1))
8989 #ifdef MOMENT
8990       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8991       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8992 #endif
8993       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8994 #ifdef MOMENT
8995       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8996       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8997       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8998 #endif
8999 c      s1d=0.0d0
9000 c      s2d=0.0d0
9001 c      s8d=0.0d0
9002 c      s12d=0.0d0
9003 c      s13d=0.0d0
9004 #ifdef MOMENT
9005       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9006      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9007 #else
9008       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9009      &               -0.5d0*ekont*(s2d+s12d)
9010 #endif
9011 C Derivatives in gamma(i+4)
9012       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9013       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9014       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9015 #ifdef MOMENT
9016       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9017       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9018       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9019 #endif
9020 c      s1d=0.0d0
9021 c      s2d=0.0d0
9022 c      s8d=0.0d0
9023 C      s12d=0.0d0
9024 c      s13d=0.0d0
9025 #ifdef MOMENT
9026       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9027 #else
9028       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9029 #endif
9030 C Derivatives in gamma(i+5)
9031 #ifdef MOMENT
9032       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9033       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9034       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9035 #endif
9036       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9037       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9038       s2d = scalar2(b1(1,itk),vtemp1d(1))
9039 #ifdef MOMENT
9040       call transpose2(AEA(1,1,2),atempd(1,1))
9041       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9042       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9043 #endif
9044       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9045       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9046 #ifdef MOMENT
9047       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9048       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9049       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9050 #endif
9051 c      s1d=0.0d0
9052 c      s2d=0.0d0
9053 c      s8d=0.0d0
9054 c      s12d=0.0d0
9055 c      s13d=0.0d0
9056 #ifdef MOMENT
9057       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9058      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9059 #else
9060       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9061      &               -0.5d0*ekont*(s2d+s12d)
9062 #endif
9063 C Cartesian derivatives
9064       do iii=1,2
9065         do kkk=1,5
9066           do lll=1,3
9067 #ifdef MOMENT
9068             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9069             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9070             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9071 #endif
9072             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9073             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9074      &          vtemp1d(1))
9075             s2d = scalar2(b1(1,itk),vtemp1d(1))
9076 #ifdef MOMENT
9077             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9078             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9079             s8d = -(atempd(1,1)+atempd(2,2))*
9080      &           scalar2(cc(1,1,itl),vtemp2(1))
9081 #endif
9082             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9083      &           auxmatd(1,1))
9084             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9085             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9086 c      s1d=0.0d0
9087 c      s2d=0.0d0
9088 c      s8d=0.0d0
9089 c      s12d=0.0d0
9090 c      s13d=0.0d0
9091 #ifdef MOMENT
9092             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9093      &        - 0.5d0*(s1d+s2d)
9094 #else
9095             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9096      &        - 0.5d0*s2d
9097 #endif
9098 #ifdef MOMENT
9099             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9100      &        - 0.5d0*(s8d+s12d)
9101 #else
9102             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9103      &        - 0.5d0*s12d
9104 #endif
9105           enddo
9106         enddo
9107       enddo
9108 #ifdef MOMENT
9109       do kkk=1,5
9110         do lll=1,3
9111           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9112      &      achuj_tempd(1,1))
9113           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9114           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9115           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9116           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9117           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9118      &      vtemp4d(1))
9119           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9120           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9121           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9122         enddo
9123       enddo
9124 #endif
9125 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9126 cd     &  16*eel_turn6_num
9127 cd      goto 1112
9128       if (j.lt.nres-1) then
9129         j1=j+1
9130         j2=j-1
9131       else
9132         j1=j-1
9133         j2=j-2
9134       endif
9135       if (l.lt.nres-1) then
9136         l1=l+1
9137         l2=l-1
9138       else
9139         l1=l-1
9140         l2=l-2
9141       endif
9142       do ll=1,3
9143 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9144 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9145 cgrad        ghalf=0.5d0*ggg1(ll)
9146 cd        ghalf=0.0d0
9147         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9148         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9149         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9150      &    +ekont*derx_turn(ll,2,1)
9151         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9152         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9153      &    +ekont*derx_turn(ll,4,1)
9154         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9155         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9156         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9157 cgrad        ghalf=0.5d0*ggg2(ll)
9158 cd        ghalf=0.0d0
9159         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9160      &    +ekont*derx_turn(ll,2,2)
9161         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9162         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9163      &    +ekont*derx_turn(ll,4,2)
9164         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9165         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9166         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9167       enddo
9168 cd      goto 1112
9169 cgrad      do m=i+1,j-1
9170 cgrad        do ll=1,3
9171 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9172 cgrad        enddo
9173 cgrad      enddo
9174 cgrad      do m=k+1,l-1
9175 cgrad        do ll=1,3
9176 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9177 cgrad        enddo
9178 cgrad      enddo
9179 cgrad1112  continue
9180 cgrad      do m=i+2,j2
9181 cgrad        do ll=1,3
9182 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9183 cgrad        enddo
9184 cgrad      enddo
9185 cgrad      do m=k+2,l2
9186 cgrad        do ll=1,3
9187 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9188 cgrad        enddo
9189 cgrad      enddo
9190 cd      do iii=1,nres-3
9191 cd        write (2,*) iii,g_corr6_loc(iii)
9192 cd      enddo
9193       eello_turn6=ekont*eel_turn6
9194 cd      write (2,*) 'ekont',ekont
9195 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9196       return
9197       end
9198
9199 C-----------------------------------------------------------------------------
9200       double precision function scalar(u,v)
9201 !DIR$ INLINEALWAYS scalar
9202 #ifndef OSF
9203 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9204 #endif
9205       implicit none
9206       double precision u(3),v(3)
9207 cd      double precision sc
9208 cd      integer i
9209 cd      sc=0.0d0
9210 cd      do i=1,3
9211 cd        sc=sc+u(i)*v(i)
9212 cd      enddo
9213 cd      scalar=sc
9214
9215       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9216       return
9217       end
9218 crc-------------------------------------------------
9219       SUBROUTINE MATVEC2(A1,V1,V2)
9220 !DIR$ INLINEALWAYS MATVEC2
9221 #ifndef OSF
9222 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9223 #endif
9224       implicit real*8 (a-h,o-z)
9225       include 'DIMENSIONS'
9226       DIMENSION A1(2,2),V1(2),V2(2)
9227 c      DO 1 I=1,2
9228 c        VI=0.0
9229 c        DO 3 K=1,2
9230 c    3     VI=VI+A1(I,K)*V1(K)
9231 c        Vaux(I)=VI
9232 c    1 CONTINUE
9233
9234       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9235       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9236
9237       v2(1)=vaux1
9238       v2(2)=vaux2
9239       END
9240 C---------------------------------------
9241       SUBROUTINE MATMAT2(A1,A2,A3)
9242 #ifndef OSF
9243 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9244 #endif
9245       implicit real*8 (a-h,o-z)
9246       include 'DIMENSIONS'
9247       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9248 c      DIMENSION AI3(2,2)
9249 c        DO  J=1,2
9250 c          A3IJ=0.0
9251 c          DO K=1,2
9252 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9253 c          enddo
9254 c          A3(I,J)=A3IJ
9255 c       enddo
9256 c      enddo
9257
9258       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9259       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9260       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9261       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9262
9263       A3(1,1)=AI3_11
9264       A3(2,1)=AI3_21
9265       A3(1,2)=AI3_12
9266       A3(2,2)=AI3_22
9267       END
9268
9269 c-------------------------------------------------------------------------
9270       double precision function scalar2(u,v)
9271 !DIR$ INLINEALWAYS scalar2
9272       implicit none
9273       double precision u(2),v(2)
9274       double precision sc
9275       integer i
9276       scalar2=u(1)*v(1)+u(2)*v(2)
9277       return
9278       end
9279
9280 C-----------------------------------------------------------------------------
9281
9282       subroutine transpose2(a,at)
9283 !DIR$ INLINEALWAYS transpose2
9284 #ifndef OSF
9285 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9286 #endif
9287       implicit none
9288       double precision a(2,2),at(2,2)
9289       at(1,1)=a(1,1)
9290       at(1,2)=a(2,1)
9291       at(2,1)=a(1,2)
9292       at(2,2)=a(2,2)
9293       return
9294       end
9295 c--------------------------------------------------------------------------
9296       subroutine transpose(n,a,at)
9297       implicit none
9298       integer n,i,j
9299       double precision a(n,n),at(n,n)
9300       do i=1,n
9301         do j=1,n
9302           at(j,i)=a(i,j)
9303         enddo
9304       enddo
9305       return
9306       end
9307 C---------------------------------------------------------------------------
9308       subroutine prodmat3(a1,a2,kk,transp,prod)
9309 !DIR$ INLINEALWAYS prodmat3
9310 #ifndef OSF
9311 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9312 #endif
9313       implicit none
9314       integer i,j
9315       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9316       logical transp
9317 crc      double precision auxmat(2,2),prod_(2,2)
9318
9319       if (transp) then
9320 crc        call transpose2(kk(1,1),auxmat(1,1))
9321 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9322 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9323
9324            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9325      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9326            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9327      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9328            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9329      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9330            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9331      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9332
9333       else
9334 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9335 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9336
9337            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9338      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9339            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9340      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9341            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9342      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9343            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9344      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9345
9346       endif
9347 c      call transpose2(a2(1,1),a2t(1,1))
9348
9349 crc      print *,transp
9350 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9351 crc      print *,((prod(i,j),i=1,2),j=1,2)
9352
9353       return
9354       end
9355