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 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.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 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c      print *," Processor",myrank," calls SUM_ENERGY"
 305       call sum_energy(energia,.true.)
 306       if (dyn_ss) call dyn_set_nss
 307 c      print *," Processor",myrank," left SUM_ENERGY"
 308 #ifdef TIMING
 309       time_sumene=time_sumene+MPI_Wtime()-time00
 310 #endif
 311       return
 312       end
 313 c-------------------------------------------------------------------------------
 314       subroutine sum_energy(energia,reduce)
 315       implicit real*8 (a-h,o-z)
 316       include 'DIMENSIONS'
 317 #ifndef ISNAN
 318       external proc_proc
 319 #ifdef WINPGI
 320 cMS$ATTRIBUTES C ::  proc_proc
 321 #endif
 322 #endif
 323 #ifdef MPI
 324       include "mpif.h"
 325 #endif
 326       include 'COMMON.SETUP'
 327       include 'COMMON.IOUNITS'
 328       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 329       include 'COMMON.FFIELD'
 330       include 'COMMON.DERIV'
 331       include 'COMMON.INTERACT'
 332       include 'COMMON.SBRIDGE'
 333       include 'COMMON.CHAIN'
 334       include 'COMMON.VAR'
 335       include 'COMMON.CONTROL'
 336       include 'COMMON.TIME1'
 337       logical reduce
 338 #ifdef MPI
 339       if (nfgtasks.gt.1 .and. reduce) then
 340 #ifdef DEBUG
 341         write (iout,*) "energies before REDUCE"
 342         call enerprint(energia)
 343         call flush(iout)
 344 #endif
 345         do i=0,n_ene
 346           enebuff(i)=energia(i)
 347         enddo
 348         time00=MPI_Wtime()
 349         call MPI_Barrier(FG_COMM,IERR)
 350         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 351         time00=MPI_Wtime()
 352         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 353      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 354 #ifdef DEBUG
 355         write (iout,*) "energies after REDUCE"
 356         call enerprint(energia)
 357         call flush(iout)
 358 #endif
 359         time_Reduce=time_Reduce+MPI_Wtime()-time00
 360       endif
 361       if (fg_rank.eq.0) then
 362 #endif
 363       evdw=energia(1)
 364 #ifdef SCP14
 365       evdw2=energia(2)+energia(18)
 366       evdw2_14=energia(18)
 367 #else
 368       evdw2=energia(2)
 369 #endif
 370 #ifdef SPLITELE
 371       ees=energia(3)
 372       evdw1=energia(16)
 373 #else
 374       ees=energia(3)
 375       evdw1=0.0d0
 376 #endif
 377       ecorr=energia(4)
 378       ecorr5=energia(5)
 379       ecorr6=energia(6)
 380       eel_loc=energia(7)
 381       eello_turn3=energia(8)
 382       eello_turn4=energia(9)
 383       eturn6=energia(10)
 384       ebe=energia(11)
 385       escloc=energia(12)
 386       etors=energia(13)
 387       etors_d=energia(14)
 388       ehpb=energia(15)
 389       edihcnstr=energia(19)
 390       estr=energia(17)
 391       Uconst=energia(20)
 392       esccor=energia(21)
 393 #ifdef SPLITELE
 394       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 395      & +wang*ebe+wtor*etors+wscloc*escloc
 396      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 397      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 398      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 399      & +wbond*estr+Uconst+wsccor*esccor
 400 #else
 401       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 402      & +wang*ebe+wtor*etors+wscloc*escloc
 403      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 404      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 405      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 406      & +wbond*estr+Uconst+wsccor*esccor
 407 #endif
 408       energia(0)=etot
 409 c detecting NaNQ
 410 #ifdef ISNAN
 411 #ifdef AIX
 412       if (isnan(etot).ne.0) energia(0)=1.0d+99
 413 #else
 414       if (isnan(etot)) energia(0)=1.0d+99
 415 #endif
 416 #else
 417       i=0
 418 #ifdef WINPGI
 419       idumm=proc_proc(etot,i)
 420 #else
 421       call proc_proc(etot,i)
 422 #endif
 423       if(i.eq.1)energia(0)=1.0d+99
 424 #endif
 425 #ifdef MPI
 426       endif
 427 #endif
 428       return
 429       end
 430 c-------------------------------------------------------------------------------
 431       subroutine sum_gradient
 432       implicit real*8 (a-h,o-z)
 433       include 'DIMENSIONS'
 434 #ifndef ISNAN
 435       external proc_proc
 436 #ifdef WINPGI
 437 cMS$ATTRIBUTES C ::  proc_proc
 438 #endif
 439 #endif
 440 #ifdef MPI
 441       include 'mpif.h'
 442 #endif
 443       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 444      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 445       include 'COMMON.SETUP'
 446       include 'COMMON.IOUNITS'
 447       include 'COMMON.FFIELD'
 448       include 'COMMON.DERIV'
 449       include 'COMMON.INTERACT'
 450       include 'COMMON.SBRIDGE'
 451       include 'COMMON.CHAIN'
 452       include 'COMMON.VAR'
 453       include 'COMMON.CONTROL'
 454       include 'COMMON.TIME1'
 455       include 'COMMON.MAXGRAD'
 456 #ifdef TIMING
 457       time01=MPI_Wtime()
 458 #endif
 459 #ifdef DEBUG
 460       write (iout,*) "sum_gradient gvdwc, gvdwx"
 461       do i=1,nres
 462         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 463      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 464       enddo
 465       call flush(iout)
 466 #endif
 467 #ifdef MPI
 468 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 469         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 470      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 471 #endif
 472 C
 473 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 474 C            in virtual-bond-vector coordinates
 475 C
 476 #ifdef DEBUG
 477 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 478 c      do i=1,nres-1
 479 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 480 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 481 c      enddo
 482 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 483 c      do i=1,nres-1
 484 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 485 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 486 c      enddo
 487       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 488       do i=1,nres
 489         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 490      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 491      &   g_corr5_loc(i)
 492       enddo
 493       call flush(iout)
 494 #endif
 495 #ifdef SPLITELE
 496       do i=1,nct
 497         do j=1,3
 498           gradbufc(j,i)=wsc*gvdwc(j,i)+
 499      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 500      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 501      &                wel_loc*gel_loc_long(j,i)+
 502      &                wcorr*gradcorr_long(j,i)+
 503      &                wcorr5*gradcorr5_long(j,i)+
 504      &                wcorr6*gradcorr6_long(j,i)+
 505      &                wturn6*gcorr6_turn_long(j,i)+
 506      &                wstrain*ghpbc(j,i)
 507         enddo
 508       enddo
 509 #else
 510       do i=1,nct
 511         do j=1,3
 512           gradbufc(j,i)=wsc*gvdwc(j,i)+
 513      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 514      &                welec*gelc_long(j,i)+
 515      &                wbond*gradb(j,i)+
 516      &                wel_loc*gel_loc_long(j,i)+
 517      &                wcorr*gradcorr_long(j,i)+
 518      &                wcorr5*gradcorr5_long(j,i)+
 519      &                wcorr6*gradcorr6_long(j,i)+
 520      &                wturn6*gcorr6_turn_long(j,i)+
 521      &                wstrain*ghpbc(j,i)
 522         enddo
 523       enddo
 524 #endif
 525 #ifdef MPI
 526       if (nfgtasks.gt.1) then
 527       time00=MPI_Wtime()
 528 #ifdef DEBUG
 529       write (iout,*) "gradbufc before allreduce"
 530       do i=1,nres
 531         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 532       enddo
 533       call flush(iout)
 534 #endif
 535       do i=1,nres
 536         do j=1,3
 537           gradbufc_sum(j,i)=gradbufc(j,i)
 538         enddo
 539       enddo
 540 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 541 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 542 c      time_reduce=time_reduce+MPI_Wtime()-time00
 543 #ifdef DEBUG
 544 c      write (iout,*) "gradbufc_sum after allreduce"
 545 c      do i=1,nres
 546 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 547 c      enddo
 548 c      call flush(iout)
 549 #endif
 550 #ifdef TIMING
 551 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 552 #endif
 553       do i=nnt,nres
 554         do k=1,3
 555           gradbufc(k,i)=0.0d0
 556         enddo
 557       enddo
 558 #ifdef DEBUG
 559       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 560       write (iout,*) (i," jgrad_start",jgrad_start(i),
 561      &                  " jgrad_end  ",jgrad_end(i),
 562      &                  i=igrad_start,igrad_end)
 563 #endif
 564 c
 565 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 566 c do not parallelize this part.
 567 c
 568 c      do i=igrad_start,igrad_end
 569 c        do j=jgrad_start(i),jgrad_end(i)
 570 c          do k=1,3
 571 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 572 c          enddo
 573 c        enddo
 574 c      enddo
 575       do j=1,3
 576         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 577       enddo
 578       do i=nres-2,nnt,-1
 579         do j=1,3
 580           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 581         enddo
 582       enddo
 583 #ifdef DEBUG
 584       write (iout,*) "gradbufc after summing"
 585       do i=1,nres
 586         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 587       enddo
 588       call flush(iout)
 589 #endif
 590       else
 591 #endif
 592 #ifdef DEBUG
 593       write (iout,*) "gradbufc"
 594       do i=1,nres
 595         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 596       enddo
 597       call flush(iout)
 598 #endif
 599       do i=1,nres
 600         do j=1,3
 601           gradbufc_sum(j,i)=gradbufc(j,i)
 602           gradbufc(j,i)=0.0d0
 603         enddo
 604       enddo
 605       do j=1,3
 606         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 607       enddo
 608       do i=nres-2,nnt,-1
 609         do j=1,3
 610           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 611         enddo
 612       enddo
 613 c      do i=nnt,nres-1
 614 c        do k=1,3
 615 c          gradbufc(k,i)=0.0d0
 616 c        enddo
 617 c        do j=i+1,nres
 618 c          do k=1,3
 619 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 620 c          enddo
 621 c        enddo
 622 c      enddo
 623 #ifdef DEBUG
 624       write (iout,*) "gradbufc after summing"
 625       do i=1,nres
 626         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 627       enddo
 628       call flush(iout)
 629 #endif
 630 #ifdef MPI
 631       endif
 632 #endif
 633       do k=1,3
 634         gradbufc(k,nres)=0.0d0
 635       enddo
 636       do i=1,nct
 637         do j=1,3
 638 #ifdef SPLITELE
 639           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 640      &                wel_loc*gel_loc(j,i)+
 641      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 642      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 643      &                wel_loc*gel_loc_long(j,i)+
 644      &                wcorr*gradcorr_long(j,i)+
 645      &                wcorr5*gradcorr5_long(j,i)+
 646      &                wcorr6*gradcorr6_long(j,i)+
 647      &                wturn6*gcorr6_turn_long(j,i))+
 648      &                wbond*gradb(j,i)+
 649      &                wcorr*gradcorr(j,i)+
 650      &                wturn3*gcorr3_turn(j,i)+
 651      &                wturn4*gcorr4_turn(j,i)+
 652      &                wcorr5*gradcorr5(j,i)+
 653      &                wcorr6*gradcorr6(j,i)+
 654      &                wturn6*gcorr6_turn(j,i)+
 655      &                wsccor*gsccorc(j,i)
 656      &               +wscloc*gscloc(j,i)
 657 #else
 658           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 659      &                wel_loc*gel_loc(j,i)+
 660      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 661      &                welec*gelc_long(j,i)
 662      &                wel_loc*gel_loc_long(j,i)+
 663      &                wcorr*gcorr_long(j,i)+
 664      &                wcorr5*gradcorr5_long(j,i)+
 665      &                wcorr6*gradcorr6_long(j,i)+
 666      &                wturn6*gcorr6_turn_long(j,i))+
 667      &                wbond*gradb(j,i)+
 668      &                wcorr*gradcorr(j,i)+
 669      &                wturn3*gcorr3_turn(j,i)+
 670      &                wturn4*gcorr4_turn(j,i)+
 671      &                wcorr5*gradcorr5(j,i)+
 672      &                wcorr6*gradcorr6(j,i)+
 673      &                wturn6*gcorr6_turn(j,i)+
 674      &                wsccor*gsccorc(j,i)
 675      &               +wscloc*gscloc(j,i)
 676 #endif
 677           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 678      &                  wbond*gradbx(j,i)+
 679      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 680      &                  wsccor*gsccorx(j,i)
 681      &                 +wscloc*gsclocx(j,i)
 682         enddo
 683       enddo
 684 #ifdef DEBUG
 685       write (iout,*) "gloc before adding corr"
 686       do i=1,4*nres
 687         write (iout,*) i,gloc(i,icg)
 688       enddo
 689 #endif
 690       do i=1,nres-3
 691         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 692      &   +wcorr5*g_corr5_loc(i)
 693      &   +wcorr6*g_corr6_loc(i)
 694      &   +wturn4*gel_loc_turn4(i)
 695      &   +wturn3*gel_loc_turn3(i)
 696      &   +wturn6*gel_loc_turn6(i)
 697      &   +wel_loc*gel_loc_loc(i)
 698      &   +wsccor*gsccor_loc(i)
 699       enddo
 700 #ifdef DEBUG
 701       write (iout,*) "gloc after adding corr"
 702       do i=1,4*nres
 703         write (iout,*) i,gloc(i,icg)
 704       enddo
 705 #endif
 706 #ifdef MPI
 707       if (nfgtasks.gt.1) then
 708         do j=1,3
 709           do i=1,nres
 710             gradbufc(j,i)=gradc(j,i,icg)
 711             gradbufx(j,i)=gradx(j,i,icg)
 712           enddo
 713         enddo
 714         do i=1,4*nres
 715           glocbuf(i)=gloc(i,icg)
 716         enddo
 717         time00=MPI_Wtime()
 718         call MPI_Barrier(FG_COMM,IERR)
 719         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 720         time00=MPI_Wtime()
 721         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 722      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 723         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 724      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 725         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 726      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 727         time_reduce=time_reduce+MPI_Wtime()-time00
 728 #ifdef DEBUG
 729       write (iout,*) "gloc after reduce"
 730       do i=1,4*nres
 731         write (iout,*) i,gloc(i,icg)
 732       enddo
 733 #endif
 734       endif
 735 #endif
 736       if (gnorm_check) then
 737 c
 738 c Compute the maximum elements of the gradient
 739 c
 740       gvdwc_max=0.0d0
 741       gvdwc_scp_max=0.0d0
 742       gelc_max=0.0d0
 743       gvdwpp_max=0.0d0
 744       gradb_max=0.0d0
 745       ghpbc_max=0.0d0
 746       gradcorr_max=0.0d0
 747       gel_loc_max=0.0d0
 748       gcorr3_turn_max=0.0d0
 749       gcorr4_turn_max=0.0d0
 750       gradcorr5_max=0.0d0
 751       gradcorr6_max=0.0d0
 752       gcorr6_turn_max=0.0d0
 753       gsccorc_max=0.0d0
 754       gscloc_max=0.0d0
 755       gvdwx_max=0.0d0
 756       gradx_scp_max=0.0d0
 757       ghpbx_max=0.0d0
 758       gradxorr_max=0.0d0
 759       gsccorx_max=0.0d0
 760       gsclocx_max=0.0d0
 761       do i=1,nct
 762         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 763         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 764         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 765         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 766      &   gvdwc_scp_max=gvdwc_scp_norm
 767         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 768         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 769         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 770         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 771         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 772         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 773         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 774         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 775         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 776         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 777         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 778         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 779         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 780      &    gcorr3_turn(1,i)))
 781         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 782      &    gcorr3_turn_max=gcorr3_turn_norm
 783         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 784      &    gcorr4_turn(1,i)))
 785         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 786      &    gcorr4_turn_max=gcorr4_turn_norm
 787         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 788         if (gradcorr5_norm.gt.gradcorr5_max)
 789      &    gradcorr5_max=gradcorr5_norm
 790         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 791         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 792         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 793      &    gcorr6_turn(1,i)))
 794         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 795      &    gcorr6_turn_max=gcorr6_turn_norm
 796         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 797         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 798         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 799         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 800         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 801         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 802         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 803         if (gradx_scp_norm.gt.gradx_scp_max)
 804      &    gradx_scp_max=gradx_scp_norm
 805         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 806         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 807         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 808         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 809         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 810         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 811         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 812         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 813       enddo
 814       if (gradout) then
 815 #ifdef AIX
 816         open(istat,file=statname,position="append")
 817 #else
 818         open(istat,file=statname,access="append")
 819 #endif
 820         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 821      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 822      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 823      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 824      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 825      &     gsccorx_max,gsclocx_max
 826         close(istat)
 827         if (gvdwc_max.gt.1.0d4) then
 828           write (iout,*) "gvdwc gvdwx gradb gradbx"
 829           do i=nnt,nct
 830             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 831      &        gradb(j,i),gradbx(j,i),j=1,3)
 832           enddo
 833           call pdbout(0.0d0,'cipiszcze',iout)
 834           call flush(iout)
 835         endif
 836       endif
 837       endif
 838 #ifdef DEBUG
 839       write (iout,*) "gradc gradx gloc"
 840       do i=1,nres
 841         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 842      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 843       enddo
 844 #endif
 845 #ifdef TIMING
 846       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 847 #endif
 848       return
 849       end
 850 c-------------------------------------------------------------------------------
 851       subroutine rescale_weights(t_bath)
 852       implicit real*8 (a-h,o-z)
 853       include 'DIMENSIONS'
 854       include 'COMMON.IOUNITS'
 855       include 'COMMON.FFIELD'
 856       include 'COMMON.SBRIDGE'
 857       double precision kfac /2.4d0/
 858       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 859 c      facT=temp0/t_bath
 860 c      facT=2*temp0/(t_bath+temp0)
 861       if (rescale_mode.eq.0) then
 862         facT=1.0d0
 863         facT2=1.0d0
 864         facT3=1.0d0
 865         facT4=1.0d0
 866         facT5=1.0d0
 867       else if (rescale_mode.eq.1) then
 868         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 869         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 870         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 871         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 872         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 873       else if (rescale_mode.eq.2) then
 874         x=t_bath/temp0
 875         x2=x*x
 876         x3=x2*x
 877         x4=x3*x
 878         x5=x4*x
 879         facT=licznik/dlog(dexp(x)+dexp(-x))
 880         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 881         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 882         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 883         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 884       else
 885         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 886         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 887 #ifdef MPI
 888        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 889 #endif
 890        stop 555
 891       endif
 892       welec=weights(3)*fact
 893       wcorr=weights(4)*fact3
 894       wcorr5=weights(5)*fact4
 895       wcorr6=weights(6)*fact5
 896       wel_loc=weights(7)*fact2
 897       wturn3=weights(8)*fact2
 898       wturn4=weights(9)*fact3
 899       wturn6=weights(10)*fact5
 900       wtor=weights(13)*fact
 901       wtor_d=weights(14)*fact2
 902       wsccor=weights(21)*fact
 903
 904       return
 905       end
 906 C------------------------------------------------------------------------
 907       subroutine enerprint(energia)
 908       implicit real*8 (a-h,o-z)
 909       include 'DIMENSIONS'
 910       include 'COMMON.IOUNITS'
 911       include 'COMMON.FFIELD'
 912       include 'COMMON.SBRIDGE'
 913       include 'COMMON.MD'
 914       double precision energia(0:n_ene)
 915       etot=energia(0)
 916       evdw=energia(1)
 917       evdw2=energia(2)
 918 #ifdef SCP14
 919       evdw2=energia(2)+energia(18)
 920 #else
 921       evdw2=energia(2)
 922 #endif
 923       ees=energia(3)
 924 #ifdef SPLITELE
 925       evdw1=energia(16)
 926 #endif
 927       ecorr=energia(4)
 928       ecorr5=energia(5)
 929       ecorr6=energia(6)
 930       eel_loc=energia(7)
 931       eello_turn3=energia(8)
 932       eello_turn4=energia(9)
 933       eello_turn6=energia(10)
 934       ebe=energia(11)
 935       escloc=energia(12)
 936       etors=energia(13)
 937       etors_d=energia(14)
 938       ehpb=energia(15)
 939       edihcnstr=energia(19)
 940       estr=energia(17)
 941       Uconst=energia(20)
 942       esccor=energia(21)
 943 #ifdef SPLITELE
 944       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 945      &  estr,wbond,ebe,wang,
 946      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 947      &  ecorr,wcorr,
 948      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 949      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 950      &  edihcnstr,ebr*nss,
 951      &  Uconst,etot
 952    10 format (/'Virtual-chain energies:'//
 953      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 954      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 955      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 956      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 957      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 958      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 959      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 960      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 961      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 962      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 963      & ' (SS bridges & dist. cnstr.)'/
 964      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 965      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 966      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 967      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 968      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 969      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 970      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 971      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 972      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 973      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 974      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 975      & 'ETOT=  ',1pE16.6,' (total)')
 976 #else
 977       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 978      &  estr,wbond,ebe,wang,
 979      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 980      &  ecorr,wcorr,
 981      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 982      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 983      &  ebr*nss,Uconst,etot
 984    10 format (/'Virtual-chain energies:'//
 985      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 986      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 987      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 988      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 989      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 990      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 991      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 992      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 993      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 994      & ' (SS bridges & dist. cnstr.)'/
 995      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 999      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1000      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1001      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1002      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1003      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1004      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1005      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1006      & 'ETOT=  ',1pE16.6,' (total)')
1007 #endif
1008       return
1009       end
1010 C-----------------------------------------------------------------------
1011       subroutine elj(evdw)
1012 C
1013 C This subroutine calculates the interaction energy of nonbonded side chains
1014 C assuming the LJ potential of interaction.
1015 C
1016       implicit real*8 (a-h,o-z)
1017       include 'DIMENSIONS'
1018       parameter (accur=1.0d-10)
1019       include 'COMMON.GEO'
1020       include 'COMMON.VAR'
1021       include 'COMMON.LOCAL'
1022       include 'COMMON.CHAIN'
1023       include 'COMMON.DERIV'
1024       include 'COMMON.INTERACT'
1025       include 'COMMON.TORSION'
1026       include 'COMMON.SBRIDGE'
1027       include 'COMMON.NAMES'
1028       include 'COMMON.IOUNITS'
1029       include 'COMMON.CONTACTS'
1030       dimension gg(3)
1031 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1032       evdw=0.0D0
1033       do i=iatsc_s,iatsc_e
1034         itypi=itype(i)
1035         if (itypi.eq.21) cycle
1036         itypi1=itype(i+1)
1037         xi=c(1,nres+i)
1038         yi=c(2,nres+i)
1039         zi=c(3,nres+i)
1040 C Change 12/1/95
1041         num_conti=0
1042 C
1043 C Calculate SC interaction energy.
1044 C
1045         do iint=1,nint_gr(i)
1046 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1047 cd   &                  'iend=',iend(i,iint)
1048           do j=istart(i,iint),iend(i,iint)
1049             itypj=itype(j)
1050             if (itypj.eq.21) cycle
1051             xj=c(1,nres+j)-xi
1052             yj=c(2,nres+j)-yi
1053             zj=c(3,nres+j)-zi
1054 C Change 12/1/95 to calculate four-body interactions
1055             rij=xj*xj+yj*yj+zj*zj
1056             rrij=1.0D0/rij
1057 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1058             eps0ij=eps(itypi,itypj)
1059             fac=rrij**expon2
1060             e1=fac*fac*aa(itypi,itypj)
1061             e2=fac*bb(itypi,itypj)
1062             evdwij=e1+e2
1063 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1064 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1065 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1066 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1067 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1068 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1069             evdw=evdw+evdwij
1070 C
1071 C Calculate the components of the gradient in DC and X
1072 C
1073             fac=-rrij*(e1+evdwij)
1074             gg(1)=xj*fac
1075             gg(2)=yj*fac
1076             gg(3)=zj*fac
1077             do k=1,3
1078               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1079               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1080               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1081               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1082             enddo
1083 cgrad            do k=i,j-1
1084 cgrad              do l=1,3
1085 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1086 cgrad              enddo
1087 cgrad            enddo
1088 C
1089 C 12/1/95, revised on 5/20/97
1090 C
1091 C Calculate the contact function. The ith column of the array JCONT will
1092 C contain the numbers of atoms that make contacts with the atom I (of numbers
1093 C greater than I). The arrays FACONT and GACONT will contain the values of
1094 C the contact function and its derivative.
1095 C
1096 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1097 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1098 C Uncomment next line, if the correlation interactions are contact function only
1099             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1100               rij=dsqrt(rij)
1101               sigij=sigma(itypi,itypj)
1102               r0ij=rs0(itypi,itypj)
1103 C
1104 C Check whether the SC's are not too far to make a contact.
1105 C
1106               rcut=1.5d0*r0ij
1107               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1108 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1109 C
1110               if (fcont.gt.0.0D0) then
1111 C If the SC-SC distance if close to sigma, apply spline.
1112 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1113 cAdam &             fcont1,fprimcont1)
1114 cAdam           fcont1=1.0d0-fcont1
1115 cAdam           if (fcont1.gt.0.0d0) then
1116 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1117 cAdam             fcont=fcont*fcont1
1118 cAdam           endif
1119 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1120 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1121 cga             do k=1,3
1122 cga               gg(k)=gg(k)*eps0ij
1123 cga             enddo
1124 cga             eps0ij=-evdwij*eps0ij
1125 C Uncomment for AL's type of SC correlation interactions.
1126 cadam           eps0ij=-evdwij
1127                 num_conti=num_conti+1
1128                 jcont(num_conti,i)=j
1129                 facont(num_conti,i)=fcont*eps0ij
1130                 fprimcont=eps0ij*fprimcont/rij
1131                 fcont=expon*fcont
1132 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1133 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1134 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1135 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1136                 gacont(1,num_conti,i)=-fprimcont*xj
1137                 gacont(2,num_conti,i)=-fprimcont*yj
1138                 gacont(3,num_conti,i)=-fprimcont*zj
1139 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1140 cd              write (iout,'(2i3,3f10.5)')
1141 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1142               endif
1143             endif
1144           enddo      ! j
1145         enddo        ! iint
1146 C Change 12/1/95
1147         num_cont(i)=num_conti
1148       enddo          ! i
1149       do i=1,nct
1150         do j=1,3
1151           gvdwc(j,i)=expon*gvdwc(j,i)
1152           gvdwx(j,i)=expon*gvdwx(j,i)
1153         enddo
1154       enddo
1155 C******************************************************************************
1156 C
1157 C                              N O T E !!!
1158 C
1159 C To save time, the factor of EXPON has been extracted from ALL components
1160 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1161 C use!
1162 C
1163 C******************************************************************************
1164       return
1165       end
1166 C-----------------------------------------------------------------------------
1167       subroutine eljk(evdw)
1168 C
1169 C This subroutine calculates the interaction energy of nonbonded side chains
1170 C assuming the LJK potential of interaction.
1171 C
1172       implicit real*8 (a-h,o-z)
1173       include 'DIMENSIONS'
1174       include 'COMMON.GEO'
1175       include 'COMMON.VAR'
1176       include 'COMMON.LOCAL'
1177       include 'COMMON.CHAIN'
1178       include 'COMMON.DERIV'
1179       include 'COMMON.INTERACT'
1180       include 'COMMON.IOUNITS'
1181       include 'COMMON.NAMES'
1182       dimension gg(3)
1183       logical scheck
1184 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1185       evdw=0.0D0
1186       do i=iatsc_s,iatsc_e
1187         itypi=itype(i)
1188         if (itypi.eq.21) cycle
1189         itypi1=itype(i+1)
1190         xi=c(1,nres+i)
1191         yi=c(2,nres+i)
1192         zi=c(3,nres+i)
1193 C
1194 C Calculate SC interaction energy.
1195 C
1196         do iint=1,nint_gr(i)
1197           do j=istart(i,iint),iend(i,iint)
1198             itypj=itype(j)
1199             if (itypj.eq.21) cycle
1200             xj=c(1,nres+j)-xi
1201             yj=c(2,nres+j)-yi
1202             zj=c(3,nres+j)-zi
1203             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1204             fac_augm=rrij**expon
1205             e_augm=augm(itypi,itypj)*fac_augm
1206             r_inv_ij=dsqrt(rrij)
1207             rij=1.0D0/r_inv_ij
1208             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1209             fac=r_shift_inv**expon
1210             e1=fac*fac*aa(itypi,itypj)
1211             e2=fac*bb(itypi,itypj)
1212             evdwij=e_augm+e1+e2
1213 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1214 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1215 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1216 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1217 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1218 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1219 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1220             evdw=evdw+evdwij
1221 C
1222 C Calculate the components of the gradient in DC and X
1223 C
1224             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1225             gg(1)=xj*fac
1226             gg(2)=yj*fac
1227             gg(3)=zj*fac
1228             do k=1,3
1229               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1230               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1231               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1232               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1233             enddo
1234 cgrad            do k=i,j-1
1235 cgrad              do l=1,3
1236 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1237 cgrad              enddo
1238 cgrad            enddo
1239           enddo      ! j
1240         enddo        ! iint
1241       enddo          ! i
1242       do i=1,nct
1243         do j=1,3
1244           gvdwc(j,i)=expon*gvdwc(j,i)
1245           gvdwx(j,i)=expon*gvdwx(j,i)
1246         enddo
1247       enddo
1248       return
1249       end
1250 C-----------------------------------------------------------------------------
1251       subroutine ebp(evdw)
1252 C
1253 C This subroutine calculates the interaction energy of nonbonded side chains
1254 C assuming the Berne-Pechukas potential of interaction.
1255 C
1256       implicit real*8 (a-h,o-z)
1257       include 'DIMENSIONS'
1258       include 'COMMON.GEO'
1259       include 'COMMON.VAR'
1260       include 'COMMON.LOCAL'
1261       include 'COMMON.CHAIN'
1262       include 'COMMON.DERIV'
1263       include 'COMMON.NAMES'
1264       include 'COMMON.INTERACT'
1265       include 'COMMON.IOUNITS'
1266       include 'COMMON.CALC'
1267       common /srutu/ icall
1268 c     double precision rrsave(maxdim)
1269       logical lprn
1270       evdw=0.0D0
1271 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1272       evdw=0.0D0
1273 c     if (icall.eq.0) then
1274 c       lprn=.true.
1275 c     else
1276         lprn=.false.
1277 c     endif
1278       ind=0
1279       do i=iatsc_s,iatsc_e
1280         itypi=itype(i)
1281         if (itypi.eq.21) cycle
1282         itypi1=itype(i+1)
1283         xi=c(1,nres+i)
1284         yi=c(2,nres+i)
1285         zi=c(3,nres+i)
1286         dxi=dc_norm(1,nres+i)
1287         dyi=dc_norm(2,nres+i)
1288         dzi=dc_norm(3,nres+i)
1289 c        dsci_inv=dsc_inv(itypi)
1290         dsci_inv=vbld_inv(i+nres)
1291 C
1292 C Calculate SC interaction energy.
1293 C
1294         do iint=1,nint_gr(i)
1295           do j=istart(i,iint),iend(i,iint)
1296             ind=ind+1
1297             itypj=itype(j)
1298             if (itypj.eq.21) cycle
1299 c            dscj_inv=dsc_inv(itypj)
1300             dscj_inv=vbld_inv(j+nres)
1301             chi1=chi(itypi,itypj)
1302             chi2=chi(itypj,itypi)
1303             chi12=chi1*chi2
1304             chip1=chip(itypi)
1305             chip2=chip(itypj)
1306             chip12=chip1*chip2
1307             alf1=alp(itypi)
1308             alf2=alp(itypj)
1309             alf12=0.5D0*(alf1+alf2)
1310 C For diagnostics only!!!
1311 c           chi1=0.0D0
1312 c           chi2=0.0D0
1313 c           chi12=0.0D0
1314 c           chip1=0.0D0
1315 c           chip2=0.0D0
1316 c           chip12=0.0D0
1317 c           alf1=0.0D0
1318 c           alf2=0.0D0
1319 c           alf12=0.0D0
1320             xj=c(1,nres+j)-xi
1321             yj=c(2,nres+j)-yi
1322             zj=c(3,nres+j)-zi
1323             dxj=dc_norm(1,nres+j)
1324             dyj=dc_norm(2,nres+j)
1325             dzj=dc_norm(3,nres+j)
1326             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1327 cd          if (icall.eq.0) then
1328 cd            rrsave(ind)=rrij
1329 cd          else
1330 cd            rrij=rrsave(ind)
1331 cd          endif
1332             rij=dsqrt(rrij)
1333 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1334             call sc_angular
1335 C Calculate whole angle-dependent part of epsilon and contributions
1336 C to its derivatives
1337             fac=(rrij*sigsq)**expon2
1338             e1=fac*fac*aa(itypi,itypj)
1339             e2=fac*bb(itypi,itypj)
1340             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1341             eps2der=evdwij*eps3rt
1342             eps3der=evdwij*eps2rt
1343             evdwij=evdwij*eps2rt*eps3rt
1344             evdw=evdw+evdwij
1345             if (lprn) then
1346             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1347             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1348 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1349 cd     &        restyp(itypi),i,restyp(itypj),j,
1350 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1351 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1352 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1353 cd     &        evdwij
1354             endif
1355 C Calculate gradient components.
1356             e1=e1*eps1*eps2rt**2*eps3rt**2
1357             fac=-expon*(e1+evdwij)
1358             sigder=fac/sigsq
1359             fac=rrij*fac
1360 C Calculate radial part of the gradient
1361             gg(1)=xj*fac
1362             gg(2)=yj*fac
1363             gg(3)=zj*fac
1364 C Calculate the angular part of the gradient and sum add the contributions
1365 C to the appropriate components of the Cartesian gradient.
1366             call sc_grad
1367           enddo      ! j
1368         enddo        ! iint
1369       enddo          ! i
1370 c     stop
1371       return
1372       end
1373 C-----------------------------------------------------------------------------
1374       subroutine egb(evdw)
1375 C
1376 C This subroutine calculates the interaction energy of nonbonded side chains
1377 C assuming the Gay-Berne potential of interaction.
1378 C
1379       implicit real*8 (a-h,o-z)
1380       include 'DIMENSIONS'
1381       include 'COMMON.GEO'
1382       include 'COMMON.VAR'
1383       include 'COMMON.LOCAL'
1384       include 'COMMON.CHAIN'
1385       include 'COMMON.DERIV'
1386       include 'COMMON.NAMES'
1387       include 'COMMON.INTERACT'
1388       include 'COMMON.IOUNITS'
1389       include 'COMMON.CALC'
1390       include 'COMMON.CONTROL'
1391       include 'COMMON.SBRIDGE'
1392       logical lprn
1393       evdw=0.0D0
1394 ccccc      energy_dec=.false.
1395 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1396       evdw=0.0D0
1397       lprn=.false.
1398 c     if (icall.eq.0) lprn=.false.
1399       ind=0
1400       do i=iatsc_s,iatsc_e
1401         itypi=itype(i)
1402         if (itypi.eq.21) cycle
1403         itypi1=itype(i+1)
1404         xi=c(1,nres+i)
1405         yi=c(2,nres+i)
1406         zi=c(3,nres+i)
1407         dxi=dc_norm(1,nres+i)
1408         dyi=dc_norm(2,nres+i)
1409         dzi=dc_norm(3,nres+i)
1410 c        dsci_inv=dsc_inv(itypi)
1411         dsci_inv=vbld_inv(i+nres)
1412 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1413 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1414 C
1415 C Calculate SC interaction energy.
1416 C
1417         do iint=1,nint_gr(i)
1418           do j=istart(i,iint),iend(i,iint)
1419             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1420               call dyn_ssbond_ene(i,j,evdwij)
1421               evdw=evdw+evdwij
1422               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1423      &                        'evdw',i,j,evdwij,' ss'
1424             ELSE
1425             ind=ind+1
1426             itypj=itype(j)
1427             if (itypj.eq.21) cycle
1428 c            dscj_inv=dsc_inv(itypj)
1429             dscj_inv=vbld_inv(j+nres)
1430 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1431 c     &       1.0d0/vbld(j+nres)
1432 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1433             sig0ij=sigma(itypi,itypj)
1434             chi1=chi(itypi,itypj)
1435             chi2=chi(itypj,itypi)
1436             chi12=chi1*chi2
1437             chip1=chip(itypi)
1438             chip2=chip(itypj)
1439             chip12=chip1*chip2
1440             alf1=alp(itypi)
1441             alf2=alp(itypj)
1442             alf12=0.5D0*(alf1+alf2)
1443 C For diagnostics only!!!
1444 c           chi1=0.0D0
1445 c           chi2=0.0D0
1446 c           chi12=0.0D0
1447 c           chip1=0.0D0
1448 c           chip2=0.0D0
1449 c           chip12=0.0D0
1450 c           alf1=0.0D0
1451 c           alf2=0.0D0
1452 c           alf12=0.0D0
1453             xj=c(1,nres+j)-xi
1454             yj=c(2,nres+j)-yi
1455             zj=c(3,nres+j)-zi
1456             dxj=dc_norm(1,nres+j)
1457             dyj=dc_norm(2,nres+j)
1458             dzj=dc_norm(3,nres+j)
1459 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1460 c            write (iout,*) "j",j," dc_norm",
1461 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1462             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1463             rij=dsqrt(rrij)
1464 C Calculate angle-dependent terms of energy and contributions to their
1465 C derivatives.
1466             call sc_angular
1467             sigsq=1.0D0/sigsq
1468             sig=sig0ij*dsqrt(sigsq)
1469             rij_shift=1.0D0/rij-sig+sig0ij
1470 c for diagnostics; uncomment
1471 c            rij_shift=1.2*sig0ij
1472 C I hate to put IF's in the loops, but here don't have another choice!!!!
1473             if (rij_shift.le.0.0D0) then
1474               evdw=1.0D20
1475 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1476 cd     &        restyp(itypi),i,restyp(itypj),j,
1477 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1478               return
1479             endif
1480             sigder=-sig*sigsq
1481 c---------------------------------------------------------------
1482             rij_shift=1.0D0/rij_shift
1483             fac=rij_shift**expon
1484             e1=fac*fac*aa(itypi,itypj)
1485             e2=fac*bb(itypi,itypj)
1486             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1487             eps2der=evdwij*eps3rt
1488             eps3der=evdwij*eps2rt
1489 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1490 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1491             evdwij=evdwij*eps2rt*eps3rt
1492             evdw=evdw+evdwij
1493             if (lprn) then
1494             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1495             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1496             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1497      &        restyp(itypi),i,restyp(itypj),j,
1498      &        epsi,sigm,chi1,chi2,chip1,chip2,
1499      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1500      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1501      &        evdwij
1502             endif
1503
1504             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1505      &                        'evdw',i,j,evdwij
1506
1507 C Calculate gradient components.
1508             e1=e1*eps1*eps2rt**2*eps3rt**2
1509             fac=-expon*(e1+evdwij)*rij_shift
1510             sigder=fac*sigder
1511             fac=rij*fac
1512 c            fac=0.0d0
1513 C Calculate the radial part of the gradient
1514             gg(1)=xj*fac
1515             gg(2)=yj*fac
1516             gg(3)=zj*fac
1517 C Calculate angular part of the gradient.
1518             call sc_grad
1519             ENDIF    ! dyn_ss
1520           enddo      ! j
1521         enddo        ! iint
1522       enddo          ! i
1523 c      write (iout,*) "Number of loop steps in EGB:",ind
1524 cccc      energy_dec=.false.
1525       return
1526       end
1527 C-----------------------------------------------------------------------------
1528       subroutine egbv(evdw)
1529 C
1530 C This subroutine calculates the interaction energy of nonbonded side chains
1531 C assuming the Gay-Berne-Vorobjev potential of interaction.
1532 C
1533       implicit real*8 (a-h,o-z)
1534       include 'DIMENSIONS'
1535       include 'COMMON.GEO'
1536       include 'COMMON.VAR'
1537       include 'COMMON.LOCAL'
1538       include 'COMMON.CHAIN'
1539       include 'COMMON.DERIV'
1540       include 'COMMON.NAMES'
1541       include 'COMMON.INTERACT'
1542       include 'COMMON.IOUNITS'
1543       include 'COMMON.CALC'
1544       common /srutu/ icall
1545       logical lprn
1546       evdw=0.0D0
1547 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1548       evdw=0.0D0
1549       lprn=.false.
1550 c     if (icall.eq.0) lprn=.true.
1551       ind=0
1552       do i=iatsc_s,iatsc_e
1553         itypi=itype(i)
1554         if (itypi.eq.21) cycle
1555         itypi1=itype(i+1)
1556         xi=c(1,nres+i)
1557         yi=c(2,nres+i)
1558         zi=c(3,nres+i)
1559         dxi=dc_norm(1,nres+i)
1560         dyi=dc_norm(2,nres+i)
1561         dzi=dc_norm(3,nres+i)
1562 c        dsci_inv=dsc_inv(itypi)
1563         dsci_inv=vbld_inv(i+nres)
1564 C
1565 C Calculate SC interaction energy.
1566 C
1567         do iint=1,nint_gr(i)
1568           do j=istart(i,iint),iend(i,iint)
1569             ind=ind+1
1570             itypj=itype(j)
1571             if (itypj.eq.21) cycle
1572 c            dscj_inv=dsc_inv(itypj)
1573             dscj_inv=vbld_inv(j+nres)
1574             sig0ij=sigma(itypi,itypj)
1575             r0ij=r0(itypi,itypj)
1576             chi1=chi(itypi,itypj)
1577             chi2=chi(itypj,itypi)
1578             chi12=chi1*chi2
1579             chip1=chip(itypi)
1580             chip2=chip(itypj)
1581             chip12=chip1*chip2
1582             alf1=alp(itypi)
1583             alf2=alp(itypj)
1584             alf12=0.5D0*(alf1+alf2)
1585 C For diagnostics only!!!
1586 c           chi1=0.0D0
1587 c           chi2=0.0D0
1588 c           chi12=0.0D0
1589 c           chip1=0.0D0
1590 c           chip2=0.0D0
1591 c           chip12=0.0D0
1592 c           alf1=0.0D0
1593 c           alf2=0.0D0
1594 c           alf12=0.0D0
1595             xj=c(1,nres+j)-xi
1596             yj=c(2,nres+j)-yi
1597             zj=c(3,nres+j)-zi
1598             dxj=dc_norm(1,nres+j)
1599             dyj=dc_norm(2,nres+j)
1600             dzj=dc_norm(3,nres+j)
1601             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1602             rij=dsqrt(rrij)
1603 C Calculate angle-dependent terms of energy and contributions to their
1604 C derivatives.
1605             call sc_angular
1606             sigsq=1.0D0/sigsq
1607             sig=sig0ij*dsqrt(sigsq)
1608             rij_shift=1.0D0/rij-sig+r0ij
1609 C I hate to put IF's in the loops, but here don't have another choice!!!!
1610             if (rij_shift.le.0.0D0) then
1611               evdw=1.0D20
1612               return
1613             endif
1614             sigder=-sig*sigsq
1615 c---------------------------------------------------------------
1616             rij_shift=1.0D0/rij_shift
1617             fac=rij_shift**expon
1618             e1=fac*fac*aa(itypi,itypj)
1619             e2=fac*bb(itypi,itypj)
1620             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1621             eps2der=evdwij*eps3rt
1622             eps3der=evdwij*eps2rt
1623             fac_augm=rrij**expon
1624             e_augm=augm(itypi,itypj)*fac_augm
1625             evdwij=evdwij*eps2rt*eps3rt
1626             evdw=evdw+evdwij+e_augm
1627             if (lprn) then
1628             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1629             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1630             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1631      &        restyp(itypi),i,restyp(itypj),j,
1632      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1633      &        chi1,chi2,chip1,chip2,
1634      &        eps1,eps2rt**2,eps3rt**2,
1635      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1636      &        evdwij+e_augm
1637             endif
1638 C Calculate gradient components.
1639             e1=e1*eps1*eps2rt**2*eps3rt**2
1640             fac=-expon*(e1+evdwij)*rij_shift
1641             sigder=fac*sigder
1642             fac=rij*fac-2*expon*rrij*e_augm
1643 C Calculate the radial part of the gradient
1644             gg(1)=xj*fac
1645             gg(2)=yj*fac
1646             gg(3)=zj*fac
1647 C Calculate angular part of the gradient.
1648             call sc_grad
1649           enddo      ! j
1650         enddo        ! iint
1651       enddo          ! i
1652       end
1653 C-----------------------------------------------------------------------------
1654       subroutine sc_angular
1655 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1656 C om12. Called by ebp, egb, and egbv.
1657       implicit none
1658       include 'COMMON.CALC'
1659       include 'COMMON.IOUNITS'
1660       erij(1)=xj*rij
1661       erij(2)=yj*rij
1662       erij(3)=zj*rij
1663       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1664       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1665       om12=dxi*dxj+dyi*dyj+dzi*dzj
1666       chiom12=chi12*om12
1667 C Calculate eps1(om12) and its derivative in om12
1668       faceps1=1.0D0-om12*chiom12
1669       faceps1_inv=1.0D0/faceps1
1670       eps1=dsqrt(faceps1_inv)
1671 C Following variable is eps1*deps1/dom12
1672       eps1_om12=faceps1_inv*chiom12
1673 c diagnostics only
1674 c      faceps1_inv=om12
1675 c      eps1=om12
1676 c      eps1_om12=1.0d0
1677 c      write (iout,*) "om12",om12," eps1",eps1
1678 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1679 C and om12.
1680       om1om2=om1*om2
1681       chiom1=chi1*om1
1682       chiom2=chi2*om2
1683       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1684       sigsq=1.0D0-facsig*faceps1_inv
1685       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1686       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1687       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1688 c diagnostics only
1689 c      sigsq=1.0d0
1690 c      sigsq_om1=0.0d0
1691 c      sigsq_om2=0.0d0
1692 c      sigsq_om12=0.0d0
1693 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1694 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1695 c     &    " eps1",eps1
1696 C Calculate eps2 and its derivatives in om1, om2, and om12.
1697       chipom1=chip1*om1
1698       chipom2=chip2*om2
1699       chipom12=chip12*om12
1700       facp=1.0D0-om12*chipom12
1701       facp_inv=1.0D0/facp
1702       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1703 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1704 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1705 C Following variable is the square root of eps2
1706       eps2rt=1.0D0-facp1*facp_inv
1707 C Following three variables are the derivatives of the square root of eps
1708 C in om1, om2, and om12.
1709       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1710       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1711       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1712 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1713       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1714 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1715 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1716 c     &  " eps2rt_om12",eps2rt_om12
1717 C Calculate whole angle-dependent part of epsilon and contributions
1718 C to its derivatives
1719       return
1720       end
1721 C----------------------------------------------------------------------------
1722       subroutine sc_grad
1723       implicit real*8 (a-h,o-z)
1724       include 'DIMENSIONS'
1725       include 'COMMON.CHAIN'
1726       include 'COMMON.DERIV'
1727       include 'COMMON.CALC'
1728       include 'COMMON.IOUNITS'
1729       double precision dcosom1(3),dcosom2(3)
1730       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1731       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1732       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1733      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1734 c diagnostics only
1735 c      eom1=0.0d0
1736 c      eom2=0.0d0
1737 c      eom12=evdwij*eps1_om12
1738 c end diagnostics
1739 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1740 c     &  " sigder",sigder
1741 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1742 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1743       do k=1,3
1744         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1745         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1746       enddo
1747       do k=1,3
1748         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1749       enddo
1750 c      write (iout,*) "gg",(gg(k),k=1,3)
1751       do k=1,3
1752         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1753      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1754      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1755         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1756      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1757      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1758 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1759 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1760 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1761 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1762       enddo
1763 C
1764 C Calculate the components of the gradient in DC and X
1765 C
1766 cgrad      do k=i,j-1
1767 cgrad        do l=1,3
1768 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1769 cgrad        enddo
1770 cgrad      enddo
1771       do l=1,3
1772         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1773         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1774       enddo
1775       return
1776       end
1777 C-----------------------------------------------------------------------
1778       subroutine e_softsphere(evdw)
1779 C
1780 C This subroutine calculates the interaction energy of nonbonded side chains
1781 C assuming the LJ potential of interaction.
1782 C
1783       implicit real*8 (a-h,o-z)
1784       include 'DIMENSIONS'
1785       parameter (accur=1.0d-10)
1786       include 'COMMON.GEO'
1787       include 'COMMON.VAR'
1788       include 'COMMON.LOCAL'
1789       include 'COMMON.CHAIN'
1790       include 'COMMON.DERIV'
1791       include 'COMMON.INTERACT'
1792       include 'COMMON.TORSION'
1793       include 'COMMON.SBRIDGE'
1794       include 'COMMON.NAMES'
1795       include 'COMMON.IOUNITS'
1796       include 'COMMON.CONTACTS'
1797       dimension gg(3)
1798 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1799       evdw=0.0D0
1800       do i=iatsc_s,iatsc_e
1801         itypi=itype(i)
1802         if (itypi.eq.21) cycle
1803         itypi1=itype(i+1)
1804         xi=c(1,nres+i)
1805         yi=c(2,nres+i)
1806         zi=c(3,nres+i)
1807 C
1808 C Calculate SC interaction energy.
1809 C
1810         do iint=1,nint_gr(i)
1811 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1812 cd   &                  'iend=',iend(i,iint)
1813           do j=istart(i,iint),iend(i,iint)
1814             itypj=itype(j)
1815             if (itypj.eq.21) cycle
1816             xj=c(1,nres+j)-xi
1817             yj=c(2,nres+j)-yi
1818             zj=c(3,nres+j)-zi
1819             rij=xj*xj+yj*yj+zj*zj
1820 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1821             r0ij=r0(itypi,itypj)
1822             r0ijsq=r0ij*r0ij
1823 c            print *,i,j,r0ij,dsqrt(rij)
1824             if (rij.lt.r0ijsq) then
1825               evdwij=0.25d0*(rij-r0ijsq)**2
1826               fac=rij-r0ijsq
1827             else
1828               evdwij=0.0d0
1829               fac=0.0d0
1830             endif
1831             evdw=evdw+evdwij
1832 C
1833 C Calculate the components of the gradient in DC and X
1834 C
1835             gg(1)=xj*fac
1836             gg(2)=yj*fac
1837             gg(3)=zj*fac
1838             do k=1,3
1839               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1840               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1841               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1842               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1843             enddo
1844 cgrad            do k=i,j-1
1845 cgrad              do l=1,3
1846 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1847 cgrad              enddo
1848 cgrad            enddo
1849           enddo ! j
1850         enddo ! iint
1851       enddo ! i
1852       return
1853       end
1854 C--------------------------------------------------------------------------
1855       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1856      &              eello_turn4)
1857 C
1858 C Soft-sphere potential of p-p interaction
1859 C
1860       implicit real*8 (a-h,o-z)
1861       include 'DIMENSIONS'
1862       include 'COMMON.CONTROL'
1863       include 'COMMON.IOUNITS'
1864       include 'COMMON.GEO'
1865       include 'COMMON.VAR'
1866       include 'COMMON.LOCAL'
1867       include 'COMMON.CHAIN'
1868       include 'COMMON.DERIV'
1869       include 'COMMON.INTERACT'
1870       include 'COMMON.CONTACTS'
1871       include 'COMMON.TORSION'
1872       include 'COMMON.VECTORS'
1873       include 'COMMON.FFIELD'
1874       dimension ggg(3)
1875 cd      write(iout,*) 'In EELEC_soft_sphere'
1876       ees=0.0D0
1877       evdw1=0.0D0
1878       eel_loc=0.0d0
1879       eello_turn3=0.0d0
1880       eello_turn4=0.0d0
1881       ind=0
1882       do i=iatel_s,iatel_e
1883         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1884         dxi=dc(1,i)
1885         dyi=dc(2,i)
1886         dzi=dc(3,i)
1887         xmedi=c(1,i)+0.5d0*dxi
1888         ymedi=c(2,i)+0.5d0*dyi
1889         zmedi=c(3,i)+0.5d0*dzi
1890         num_conti=0
1891 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1892         do j=ielstart(i),ielend(i)
1893           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1894           ind=ind+1
1895           iteli=itel(i)
1896           itelj=itel(j)
1897           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1898           r0ij=rpp(iteli,itelj)
1899           r0ijsq=r0ij*r0ij
1900           dxj=dc(1,j)
1901           dyj=dc(2,j)
1902           dzj=dc(3,j)
1903           xj=c(1,j)+0.5D0*dxj-xmedi
1904           yj=c(2,j)+0.5D0*dyj-ymedi
1905           zj=c(3,j)+0.5D0*dzj-zmedi
1906           rij=xj*xj+yj*yj+zj*zj
1907           if (rij.lt.r0ijsq) then
1908             evdw1ij=0.25d0*(rij-r0ijsq)**2
1909             fac=rij-r0ijsq
1910           else
1911             evdw1ij=0.0d0
1912             fac=0.0d0
1913           endif
1914           evdw1=evdw1+evdw1ij
1915 C
1916 C Calculate contributions to the Cartesian gradient.
1917 C
1918           ggg(1)=fac*xj
1919           ggg(2)=fac*yj
1920           ggg(3)=fac*zj
1921           do k=1,3
1922             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1923             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1924           enddo
1925 *
1926 * Loop over residues i+1 thru j-1.
1927 *
1928 cgrad          do k=i+1,j-1
1929 cgrad            do l=1,3
1930 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1931 cgrad            enddo
1932 cgrad          enddo
1933         enddo ! j
1934       enddo   ! i
1935 cgrad      do i=nnt,nct-1
1936 cgrad        do k=1,3
1937 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1938 cgrad        enddo
1939 cgrad        do j=i+1,nct-1
1940 cgrad          do k=1,3
1941 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1942 cgrad          enddo
1943 cgrad        enddo
1944 cgrad      enddo
1945       return
1946       end
1947 c------------------------------------------------------------------------------
1948       subroutine vec_and_deriv
1949       implicit real*8 (a-h,o-z)
1950       include 'DIMENSIONS'
1951 #ifdef MPI
1952       include 'mpif.h'
1953 #endif
1954       include 'COMMON.IOUNITS'
1955       include 'COMMON.GEO'
1956       include 'COMMON.VAR'
1957       include 'COMMON.LOCAL'
1958       include 'COMMON.CHAIN'
1959       include 'COMMON.VECTORS'
1960       include 'COMMON.SETUP'
1961       include 'COMMON.TIME1'
1962       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1963 C Compute the local reference systems. For reference system (i), the
1964 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1965 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1966 #ifdef PARVEC
1967       do i=ivec_start,ivec_end
1968 #else
1969       do i=1,nres-1
1970 #endif
1971           if (i.eq.nres-1) then
1972 C Case of the last full residue
1973 C Compute the Z-axis
1974             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1975             costh=dcos(pi-theta(nres))
1976             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1977             do k=1,3
1978               uz(k,i)=fac*uz(k,i)
1979             enddo
1980 C Compute the derivatives of uz
1981             uzder(1,1,1)= 0.0d0
1982             uzder(2,1,1)=-dc_norm(3,i-1)
1983             uzder(3,1,1)= dc_norm(2,i-1)
1984             uzder(1,2,1)= dc_norm(3,i-1)
1985             uzder(2,2,1)= 0.0d0
1986             uzder(3,2,1)=-dc_norm(1,i-1)
1987             uzder(1,3,1)=-dc_norm(2,i-1)
1988             uzder(2,3,1)= dc_norm(1,i-1)
1989             uzder(3,3,1)= 0.0d0
1990             uzder(1,1,2)= 0.0d0
1991             uzder(2,1,2)= dc_norm(3,i)
1992             uzder(3,1,2)=-dc_norm(2,i)
1993             uzder(1,2,2)=-dc_norm(3,i)
1994             uzder(2,2,2)= 0.0d0
1995             uzder(3,2,2)= dc_norm(1,i)
1996             uzder(1,3,2)= dc_norm(2,i)
1997             uzder(2,3,2)=-dc_norm(1,i)
1998             uzder(3,3,2)= 0.0d0
1999 C Compute the Y-axis
2000             facy=fac
2001             do k=1,3
2002               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2003             enddo
2004 C Compute the derivatives of uy
2005             do j=1,3
2006               do k=1,3
2007                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2008      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2009                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2010               enddo
2011               uyder(j,j,1)=uyder(j,j,1)-costh
2012               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2013             enddo
2014             do j=1,2
2015               do k=1,3
2016                 do l=1,3
2017                   uygrad(l,k,j,i)=uyder(l,k,j)
2018                   uzgrad(l,k,j,i)=uzder(l,k,j)
2019                 enddo
2020               enddo
2021             enddo
2022             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2023             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2024             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2025             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2026           else
2027 C Other residues
2028 C Compute the Z-axis
2029             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2030             costh=dcos(pi-theta(i+2))
2031             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2032             do k=1,3
2033               uz(k,i)=fac*uz(k,i)
2034             enddo
2035 C Compute the derivatives of uz
2036             uzder(1,1,1)= 0.0d0
2037             uzder(2,1,1)=-dc_norm(3,i+1)
2038             uzder(3,1,1)= dc_norm(2,i+1)
2039             uzder(1,2,1)= dc_norm(3,i+1)
2040             uzder(2,2,1)= 0.0d0
2041             uzder(3,2,1)=-dc_norm(1,i+1)
2042             uzder(1,3,1)=-dc_norm(2,i+1)
2043             uzder(2,3,1)= dc_norm(1,i+1)
2044             uzder(3,3,1)= 0.0d0
2045             uzder(1,1,2)= 0.0d0
2046             uzder(2,1,2)= dc_norm(3,i)
2047             uzder(3,1,2)=-dc_norm(2,i)
2048             uzder(1,2,2)=-dc_norm(3,i)
2049             uzder(2,2,2)= 0.0d0
2050             uzder(3,2,2)= dc_norm(1,i)
2051             uzder(1,3,2)= dc_norm(2,i)
2052             uzder(2,3,2)=-dc_norm(1,i)
2053             uzder(3,3,2)= 0.0d0
2054 C Compute the Y-axis
2055             facy=fac
2056             do k=1,3
2057               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2058             enddo
2059 C Compute the derivatives of uy
2060             do j=1,3
2061               do k=1,3
2062                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2063      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2064                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2065               enddo
2066               uyder(j,j,1)=uyder(j,j,1)-costh
2067               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2068             enddo
2069             do j=1,2
2070               do k=1,3
2071                 do l=1,3
2072                   uygrad(l,k,j,i)=uyder(l,k,j)
2073                   uzgrad(l,k,j,i)=uzder(l,k,j)
2074                 enddo
2075               enddo
2076             enddo
2077             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2078             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2079             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2080             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2081           endif
2082       enddo
2083       do i=1,nres-1
2084         vbld_inv_temp(1)=vbld_inv(i+1)
2085         if (i.lt.nres-1) then
2086           vbld_inv_temp(2)=vbld_inv(i+2)
2087           else
2088           vbld_inv_temp(2)=vbld_inv(i)
2089           endif
2090         do j=1,2
2091           do k=1,3
2092             do l=1,3
2093               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2094               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2095             enddo
2096           enddo
2097         enddo
2098       enddo
2099 #if defined(PARVEC) && defined(MPI)
2100       if (nfgtasks1.gt.1) then
2101         time00=MPI_Wtime()
2102 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2103 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2104 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2105         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2106      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2107      &   FG_COMM1,IERR)
2108         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2109      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2110      &   FG_COMM1,IERR)
2111         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2112      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2113      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2114         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2115      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2116      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2117         time_gather=time_gather+MPI_Wtime()-time00
2118       endif
2119 c      if (fg_rank.eq.0) then
2120 c        write (iout,*) "Arrays UY and UZ"
2121 c        do i=1,nres-1
2122 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2123 c     &     (uz(k,i),k=1,3)
2124 c        enddo
2125 c      endif
2126 #endif
2127       return
2128       end
2129 C-----------------------------------------------------------------------------
2130       subroutine check_vecgrad
2131       implicit real*8 (a-h,o-z)
2132       include 'DIMENSIONS'
2133       include 'COMMON.IOUNITS'
2134       include 'COMMON.GEO'
2135       include 'COMMON.VAR'
2136       include 'COMMON.LOCAL'
2137       include 'COMMON.CHAIN'
2138       include 'COMMON.VECTORS'
2139       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2140       dimension uyt(3,maxres),uzt(3,maxres)
2141       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2142       double precision delta /1.0d-7/
2143       call vec_and_deriv
2144 cd      do i=1,nres
2145 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2146 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2147 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2148 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2149 cd     &     (dc_norm(if90,i),if90=1,3)
2150 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2151 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2152 cd          write(iout,'(a)')
2153 cd      enddo
2154       do i=1,nres
2155         do j=1,2
2156           do k=1,3
2157             do l=1,3
2158               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2159               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2160             enddo
2161           enddo
2162         enddo
2163       enddo
2164       call vec_and_deriv
2165       do i=1,nres
2166         do j=1,3
2167           uyt(j,i)=uy(j,i)
2168           uzt(j,i)=uz(j,i)
2169         enddo
2170       enddo
2171       do i=1,nres
2172 cd        write (iout,*) 'i=',i
2173         do k=1,3
2174           erij(k)=dc_norm(k,i)
2175         enddo
2176         do j=1,3
2177           do k=1,3
2178             dc_norm(k,i)=erij(k)
2179           enddo
2180           dc_norm(j,i)=dc_norm(j,i)+delta
2181 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2182 c          do k=1,3
2183 c            dc_norm(k,i)=dc_norm(k,i)/fac
2184 c          enddo
2185 c          write (iout,*) (dc_norm(k,i),k=1,3)
2186 c          write (iout,*) (erij(k),k=1,3)
2187           call vec_and_deriv
2188           do k=1,3
2189             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2190             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2191             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2192             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2193           enddo
2194 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2195 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2196 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2197         enddo
2198         do k=1,3
2199           dc_norm(k,i)=erij(k)
2200         enddo
2201 cd        do k=1,3
2202 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2203 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2204 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2205 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2206 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2207 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2208 cd          write (iout,'(a)')
2209 cd        enddo
2210       enddo
2211       return
2212       end
2213 C--------------------------------------------------------------------------
2214       subroutine set_matrices
2215       implicit real*8 (a-h,o-z)
2216       include 'DIMENSIONS'
2217 #ifdef MPI
2218       include "mpif.h"
2219       include "COMMON.SETUP"
2220       integer IERR
2221       integer status(MPI_STATUS_SIZE)
2222 #endif
2223       include 'COMMON.IOUNITS'
2224       include 'COMMON.GEO'
2225       include 'COMMON.VAR'
2226       include 'COMMON.LOCAL'
2227       include 'COMMON.CHAIN'
2228       include 'COMMON.DERIV'
2229       include 'COMMON.INTERACT'
2230       include 'COMMON.CONTACTS'
2231       include 'COMMON.TORSION'
2232       include 'COMMON.VECTORS'
2233       include 'COMMON.FFIELD'
2234       double precision auxvec(2),auxmat(2,2)
2235 C
2236 C Compute the virtual-bond-torsional-angle dependent quantities needed
2237 C to calculate the el-loc multibody terms of various order.
2238 C
2239 #ifdef PARMAT
2240       do i=ivec_start+2,ivec_end+2
2241 #else
2242       do i=3,nres+1
2243 #endif
2244         if (i .lt. nres+1) then
2245           sin1=dsin(phi(i))
2246           cos1=dcos(phi(i))
2247           sintab(i-2)=sin1
2248           costab(i-2)=cos1
2249           obrot(1,i-2)=cos1
2250           obrot(2,i-2)=sin1
2251           sin2=dsin(2*phi(i))
2252           cos2=dcos(2*phi(i))
2253           sintab2(i-2)=sin2
2254           costab2(i-2)=cos2
2255           obrot2(1,i-2)=cos2
2256           obrot2(2,i-2)=sin2
2257           Ug(1,1,i-2)=-cos1
2258           Ug(1,2,i-2)=-sin1
2259           Ug(2,1,i-2)=-sin1
2260           Ug(2,2,i-2)= cos1
2261           Ug2(1,1,i-2)=-cos2
2262           Ug2(1,2,i-2)=-sin2
2263           Ug2(2,1,i-2)=-sin2
2264           Ug2(2,2,i-2)= cos2
2265         else
2266           costab(i-2)=1.0d0
2267           sintab(i-2)=0.0d0
2268           obrot(1,i-2)=1.0d0
2269           obrot(2,i-2)=0.0d0
2270           obrot2(1,i-2)=0.0d0
2271           obrot2(2,i-2)=0.0d0
2272           Ug(1,1,i-2)=1.0d0
2273           Ug(1,2,i-2)=0.0d0
2274           Ug(2,1,i-2)=0.0d0
2275           Ug(2,2,i-2)=1.0d0
2276           Ug2(1,1,i-2)=0.0d0
2277           Ug2(1,2,i-2)=0.0d0
2278           Ug2(2,1,i-2)=0.0d0
2279           Ug2(2,2,i-2)=0.0d0
2280         endif
2281         if (i .gt. 3 .and. i .lt. nres+1) then
2282           obrot_der(1,i-2)=-sin1
2283           obrot_der(2,i-2)= cos1
2284           Ugder(1,1,i-2)= sin1
2285           Ugder(1,2,i-2)=-cos1
2286           Ugder(2,1,i-2)=-cos1
2287           Ugder(2,2,i-2)=-sin1
2288           dwacos2=cos2+cos2
2289           dwasin2=sin2+sin2
2290           obrot2_der(1,i-2)=-dwasin2
2291           obrot2_der(2,i-2)= dwacos2
2292           Ug2der(1,1,i-2)= dwasin2
2293           Ug2der(1,2,i-2)=-dwacos2
2294           Ug2der(2,1,i-2)=-dwacos2
2295           Ug2der(2,2,i-2)=-dwasin2
2296         else
2297           obrot_der(1,i-2)=0.0d0
2298           obrot_der(2,i-2)=0.0d0
2299           Ugder(1,1,i-2)=0.0d0
2300           Ugder(1,2,i-2)=0.0d0
2301           Ugder(2,1,i-2)=0.0d0
2302           Ugder(2,2,i-2)=0.0d0
2303           obrot2_der(1,i-2)=0.0d0
2304           obrot2_der(2,i-2)=0.0d0
2305           Ug2der(1,1,i-2)=0.0d0
2306           Ug2der(1,2,i-2)=0.0d0
2307           Ug2der(2,1,i-2)=0.0d0
2308           Ug2der(2,2,i-2)=0.0d0
2309         endif
2310 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2311         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2312           iti = itortyp(itype(i-2))
2313         else
2314           iti=ntortyp+1
2315         endif
2316 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2317         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2318           iti1 = itortyp(itype(i-1))
2319         else
2320           iti1=ntortyp+1
2321         endif
2322 cd        write (iout,*) '*******i',i,' iti1',iti
2323 cd        write (iout,*) 'b1',b1(:,iti)
2324 cd        write (iout,*) 'b2',b2(:,iti)
2325 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2326 c        if (i .gt. iatel_s+2) then
2327         if (i .gt. nnt+2) then
2328           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2329           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2330           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2331      &    then
2332           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2333           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2334           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2335           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2336           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2337           endif
2338         else
2339           do k=1,2
2340             Ub2(k,i-2)=0.0d0
2341             Ctobr(k,i-2)=0.0d0
2342             Dtobr2(k,i-2)=0.0d0
2343             do l=1,2
2344               EUg(l,k,i-2)=0.0d0
2345               CUg(l,k,i-2)=0.0d0
2346               DUg(l,k,i-2)=0.0d0
2347               DtUg2(l,k,i-2)=0.0d0
2348             enddo
2349           enddo
2350         endif
2351         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2352         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2353         do k=1,2
2354           muder(k,i-2)=Ub2der(k,i-2)
2355         enddo
2356 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2357         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2358           iti1 = itortyp(itype(i-1))
2359         else
2360           iti1=ntortyp+1
2361         endif
2362         do k=1,2
2363           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2364         enddo
2365 cd        write (iout,*) 'mu ',mu(:,i-2)
2366 cd        write (iout,*) 'mu1',mu1(:,i-2)
2367 cd        write (iout,*) 'mu2',mu2(:,i-2)
2368         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2369      &  then
2370         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2371         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2372         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2373         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2374         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2375 C Vectors and matrices dependent on a single virtual-bond dihedral.
2376         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2377         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2378         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2379         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2380         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2381         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2382         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2383         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2384         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2385         endif
2386       enddo
2387 C Matrices dependent on two consecutive virtual-bond dihedrals.
2388 C The order of matrices is from left to right.
2389       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2390      &then
2391 c      do i=max0(ivec_start,2),ivec_end
2392       do i=2,nres-1
2393         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2394         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2395         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2396         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2397         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2398         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2399         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2400         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2401       enddo
2402       endif
2403 #if defined(MPI) && defined(PARMAT)
2404 #ifdef DEBUG
2405 c      if (fg_rank.eq.0) then
2406         write (iout,*) "Arrays UG and UGDER before GATHER"
2407         do i=1,nres-1
2408           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2409      &     ((ug(l,k,i),l=1,2),k=1,2),
2410      &     ((ugder(l,k,i),l=1,2),k=1,2)
2411         enddo
2412         write (iout,*) "Arrays UG2 and UG2DER"
2413         do i=1,nres-1
2414           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2415      &     ((ug2(l,k,i),l=1,2),k=1,2),
2416      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2417         enddo
2418         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2419         do i=1,nres-1
2420           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2421      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2422      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2423         enddo
2424         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2425         do i=1,nres-1
2426           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2427      &     costab(i),sintab(i),costab2(i),sintab2(i)
2428         enddo
2429         write (iout,*) "Array MUDER"
2430         do i=1,nres-1
2431           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2432         enddo
2433 c      endif
2434 #endif
2435       if (nfgtasks.gt.1) then
2436         time00=MPI_Wtime()
2437 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2438 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2439 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2440 #ifdef MATGATHER
2441         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2442      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2443      &   FG_COMM1,IERR)
2444         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2445      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2446      &   FG_COMM1,IERR)
2447         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2448      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2449      &   FG_COMM1,IERR)
2450         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2451      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2452      &   FG_COMM1,IERR)
2453         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2454      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2455      &   FG_COMM1,IERR)
2456         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2457      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2458      &   FG_COMM1,IERR)
2459         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2460      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2461      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2462         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2463      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2464      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2465         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2466      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2467      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2468         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2469      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2470      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2471         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2472      &  then
2473         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2474      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2475      &   FG_COMM1,IERR)
2476         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2477      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2478      &   FG_COMM1,IERR)
2479         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2480      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2481      &   FG_COMM1,IERR)
2482        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2483      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2484      &   FG_COMM1,IERR)
2485         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2486      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2487      &   FG_COMM1,IERR)
2488         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2489      &   ivec_count(fg_rank1),
2490      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2491      &   FG_COMM1,IERR)
2492         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2493      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2494      &   FG_COMM1,IERR)
2495         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2496      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2497      &   FG_COMM1,IERR)
2498         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2499      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2500      &   FG_COMM1,IERR)
2501         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2502      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2503      &   FG_COMM1,IERR)
2504         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2505      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2506      &   FG_COMM1,IERR)
2507         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2514      &   ivec_count(fg_rank1),
2515      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2516      &   FG_COMM1,IERR)
2517         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2518      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2519      &   FG_COMM1,IERR)
2520        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2521      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2522      &   FG_COMM1,IERR)
2523         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2524      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2525      &   FG_COMM1,IERR)
2526        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2527      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2528      &   FG_COMM1,IERR)
2529         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2530      &   ivec_count(fg_rank1),
2531      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2534      &   ivec_count(fg_rank1),
2535      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2536      &   FG_COMM1,IERR)
2537         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2538      &   ivec_count(fg_rank1),
2539      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2540      &   MPI_MAT2,FG_COMM1,IERR)
2541         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2542      &   ivec_count(fg_rank1),
2543      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2544      &   MPI_MAT2,FG_COMM1,IERR)
2545         endif
2546 #else
2547 c Passes matrix info through the ring
2548       isend=fg_rank1
2549       irecv=fg_rank1-1
2550       if (irecv.lt.0) irecv=nfgtasks1-1
2551       iprev=irecv
2552       inext=fg_rank1+1
2553       if (inext.ge.nfgtasks1) inext=0
2554       do i=1,nfgtasks1-1
2555 c        write (iout,*) "isend",isend," irecv",irecv
2556 c        call flush(iout)
2557         lensend=lentyp(isend)
2558         lenrecv=lentyp(irecv)
2559 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2560 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2561 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2562 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2563 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2564 c        write (iout,*) "Gather ROTAT1"
2565 c        call flush(iout)
2566 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2567 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2568 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2569 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2570 c        write (iout,*) "Gather ROTAT2"
2571 c        call flush(iout)
2572         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2573      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2574      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2575      &   iprev,4400+irecv,FG_COMM,status,IERR)
2576 c        write (iout,*) "Gather ROTAT_OLD"
2577 c        call flush(iout)
2578         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2579      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2580      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2581      &   iprev,5500+irecv,FG_COMM,status,IERR)
2582 c        write (iout,*) "Gather PRECOMP11"
2583 c        call flush(iout)
2584         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2585      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2586      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2587      &   iprev,6600+irecv,FG_COMM,status,IERR)
2588 c        write (iout,*) "Gather PRECOMP12"
2589 c        call flush(iout)
2590         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2591      &  then
2592         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2593      &   MPI_ROTAT2(lensend),inext,7700+isend,
2594      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2595      &   iprev,7700+irecv,FG_COMM,status,IERR)
2596 c        write (iout,*) "Gather PRECOMP21"
2597 c        call flush(iout)
2598         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2599      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2600      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2601      &   iprev,8800+irecv,FG_COMM,status,IERR)
2602 c        write (iout,*) "Gather PRECOMP22"
2603 c        call flush(iout)
2604         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2605      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2606      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2607      &   MPI_PRECOMP23(lenrecv),
2608      &   iprev,9900+irecv,FG_COMM,status,IERR)
2609 c        write (iout,*) "Gather PRECOMP23"
2610 c        call flush(iout)
2611         endif
2612         isend=irecv
2613         irecv=irecv-1
2614         if (irecv.lt.0) irecv=nfgtasks1-1
2615       enddo
2616 #endif
2617         time_gather=time_gather+MPI_Wtime()-time00
2618       endif
2619 #ifdef DEBUG
2620 c      if (fg_rank.eq.0) then
2621         write (iout,*) "Arrays UG and UGDER"
2622         do i=1,nres-1
2623           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2624      &     ((ug(l,k,i),l=1,2),k=1,2),
2625      &     ((ugder(l,k,i),l=1,2),k=1,2)
2626         enddo
2627         write (iout,*) "Arrays UG2 and UG2DER"
2628         do i=1,nres-1
2629           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2630      &     ((ug2(l,k,i),l=1,2),k=1,2),
2631      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2632         enddo
2633         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2634         do i=1,nres-1
2635           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2636      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2637      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2638         enddo
2639         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2640         do i=1,nres-1
2641           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2642      &     costab(i),sintab(i),costab2(i),sintab2(i)
2643         enddo
2644         write (iout,*) "Array MUDER"
2645         do i=1,nres-1
2646           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2647         enddo
2648 c      endif
2649 #endif
2650 #endif
2651 cd      do i=1,nres
2652 cd        iti = itortyp(itype(i))
2653 cd        write (iout,*) i
2654 cd        do j=1,2
2655 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2656 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2657 cd        enddo
2658 cd      enddo
2659       return
2660       end
2661 C--------------------------------------------------------------------------
2662       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2663 C
2664 C This subroutine calculates the average interaction energy and its gradient
2665 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2666 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2667 C The potential depends both on the distance of peptide-group centers and on
2668 C the orientation of the CA-CA virtual bonds.
2669 C
2670       implicit real*8 (a-h,o-z)
2671 #ifdef MPI
2672       include 'mpif.h'
2673 #endif
2674       include 'DIMENSIONS'
2675       include 'COMMON.CONTROL'
2676       include 'COMMON.SETUP'
2677       include 'COMMON.IOUNITS'
2678       include 'COMMON.GEO'
2679       include 'COMMON.VAR'
2680       include 'COMMON.LOCAL'
2681       include 'COMMON.CHAIN'
2682       include 'COMMON.DERIV'
2683       include 'COMMON.INTERACT'
2684       include 'COMMON.CONTACTS'
2685       include 'COMMON.TORSION'
2686       include 'COMMON.VECTORS'
2687       include 'COMMON.FFIELD'
2688       include 'COMMON.TIME1'
2689       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2690      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2691       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2692      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2693       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2694      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2695      &    num_conti,j1,j2
2696 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2697 #ifdef MOMENT
2698       double precision scal_el /1.0d0/
2699 #else
2700       double precision scal_el /0.5d0/
2701 #endif
2702 C 12/13/98
2703 C 13-go grudnia roku pamietnego...
2704       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2705      &                   0.0d0,1.0d0,0.0d0,
2706      &                   0.0d0,0.0d0,1.0d0/
2707 cd      write(iout,*) 'In EELEC'
2708 cd      do i=1,nloctyp
2709 cd        write(iout,*) 'Type',i
2710 cd        write(iout,*) 'B1',B1(:,i)
2711 cd        write(iout,*) 'B2',B2(:,i)
2712 cd        write(iout,*) 'CC',CC(:,:,i)
2713 cd        write(iout,*) 'DD',DD(:,:,i)
2714 cd        write(iout,*) 'EE',EE(:,:,i)
2715 cd      enddo
2716 cd      call check_vecgrad
2717 cd      stop
2718       if (icheckgrad.eq.1) then
2719         do i=1,nres-1
2720           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2721           do k=1,3
2722             dc_norm(k,i)=dc(k,i)*fac
2723           enddo
2724 c          write (iout,*) 'i',i,' fac',fac
2725         enddo
2726       endif
2727       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2728      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2729      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2730 c        call vec_and_deriv
2731 #ifdef TIMING
2732         time01=MPI_Wtime()
2733 #endif
2734         call set_matrices
2735 #ifdef TIMING
2736         time_mat=time_mat+MPI_Wtime()-time01
2737 #endif
2738       endif
2739 cd      do i=1,nres-1
2740 cd        write (iout,*) 'i=',i
2741 cd        do k=1,3
2742 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2743 cd        enddo
2744 cd        do k=1,3
2745 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2746 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2747 cd        enddo
2748 cd      enddo
2749       t_eelecij=0.0d0
2750       ees=0.0D0
2751       evdw1=0.0D0
2752       eel_loc=0.0d0
2753       eello_turn3=0.0d0
2754       eello_turn4=0.0d0
2755       ind=0
2756       do i=1,nres
2757         num_cont_hb(i)=0
2758       enddo
2759 cd      print '(a)','Enter EELEC'
2760 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2761       do i=1,nres
2762         gel_loc_loc(i)=0.0d0
2763         gcorr_loc(i)=0.0d0
2764       enddo
2765 c
2766 c
2767 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2768 C
2769 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2770 C
2771       do i=iturn3_start,iturn3_end
2772         if (itype(i).eq.21 .or. itype(i+1).eq.21
2773      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2774         dxi=dc(1,i)
2775         dyi=dc(2,i)
2776         dzi=dc(3,i)
2777         dx_normi=dc_norm(1,i)
2778         dy_normi=dc_norm(2,i)
2779         dz_normi=dc_norm(3,i)
2780         xmedi=c(1,i)+0.5d0*dxi
2781         ymedi=c(2,i)+0.5d0*dyi
2782         zmedi=c(3,i)+0.5d0*dzi
2783         num_conti=0
2784         call eelecij(i,i+2,ees,evdw1,eel_loc)
2785         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2786         num_cont_hb(i)=num_conti
2787       enddo
2788       do i=iturn4_start,iturn4_end
2789         if (itype(i).eq.21 .or. itype(i+1).eq.21
2790      &    .or. itype(i+3).eq.21
2791      &    .or. itype(i+4).eq.21) cycle
2792         dxi=dc(1,i)
2793         dyi=dc(2,i)
2794         dzi=dc(3,i)
2795         dx_normi=dc_norm(1,i)
2796         dy_normi=dc_norm(2,i)
2797         dz_normi=dc_norm(3,i)
2798         xmedi=c(1,i)+0.5d0*dxi
2799         ymedi=c(2,i)+0.5d0*dyi
2800         zmedi=c(3,i)+0.5d0*dzi
2801         num_conti=num_cont_hb(i)
2802         call eelecij(i,i+3,ees,evdw1,eel_loc)
2803         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2804      &   call eturn4(i,eello_turn4)
2805         num_cont_hb(i)=num_conti
2806       enddo   ! i
2807 c
2808 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2809 c
2810       do i=iatel_s,iatel_e
2811         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2812         dxi=dc(1,i)
2813         dyi=dc(2,i)
2814         dzi=dc(3,i)
2815         dx_normi=dc_norm(1,i)
2816         dy_normi=dc_norm(2,i)
2817         dz_normi=dc_norm(3,i)
2818         xmedi=c(1,i)+0.5d0*dxi
2819         ymedi=c(2,i)+0.5d0*dyi
2820         zmedi=c(3,i)+0.5d0*dzi
2821 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2822         num_conti=num_cont_hb(i)
2823         do j=ielstart(i),ielend(i)
2824 c          write (iout,*) i,j,itype(i),itype(j)
2825           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2826           call eelecij(i,j,ees,evdw1,eel_loc)
2827         enddo ! j
2828         num_cont_hb(i)=num_conti
2829       enddo   ! i
2830 c      write (iout,*) "Number of loop steps in EELEC:",ind
2831 cd      do i=1,nres
2832 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2833 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2834 cd      enddo
2835 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2836 ccc      eel_loc=eel_loc+eello_turn3
2837 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2838       return
2839       end
2840 C-------------------------------------------------------------------------------
2841       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2842       implicit real*8 (a-h,o-z)
2843       include 'DIMENSIONS'
2844 #ifdef MPI
2845       include "mpif.h"
2846 #endif
2847       include 'COMMON.CONTROL'
2848       include 'COMMON.IOUNITS'
2849       include 'COMMON.GEO'
2850       include 'COMMON.VAR'
2851       include 'COMMON.LOCAL'
2852       include 'COMMON.CHAIN'
2853       include 'COMMON.DERIV'
2854       include 'COMMON.INTERACT'
2855       include 'COMMON.CONTACTS'
2856       include 'COMMON.TORSION'
2857       include 'COMMON.VECTORS'
2858       include 'COMMON.FFIELD'
2859       include 'COMMON.TIME1'
2860       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2861      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2862       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2863      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2864       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2865      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2866      &    num_conti,j1,j2
2867 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2868 #ifdef MOMENT
2869       double precision scal_el /1.0d0/
2870 #else
2871       double precision scal_el /0.5d0/
2872 #endif
2873 C 12/13/98
2874 C 13-go grudnia roku pamietnego...
2875       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2876      &                   0.0d0,1.0d0,0.0d0,
2877      &                   0.0d0,0.0d0,1.0d0/
2878 c          time00=MPI_Wtime()
2879 cd      write (iout,*) "eelecij",i,j
2880 c          ind=ind+1
2881           iteli=itel(i)
2882           itelj=itel(j)
2883           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2884           aaa=app(iteli,itelj)
2885           bbb=bpp(iteli,itelj)
2886           ael6i=ael6(iteli,itelj)
2887           ael3i=ael3(iteli,itelj)
2888           dxj=dc(1,j)
2889           dyj=dc(2,j)
2890           dzj=dc(3,j)
2891           dx_normj=dc_norm(1,j)
2892           dy_normj=dc_norm(2,j)
2893           dz_normj=dc_norm(3,j)
2894           xj=c(1,j)+0.5D0*dxj-xmedi
2895           yj=c(2,j)+0.5D0*dyj-ymedi
2896           zj=c(3,j)+0.5D0*dzj-zmedi
2897           rij=xj*xj+yj*yj+zj*zj
2898           rrmij=1.0D0/rij
2899           rij=dsqrt(rij)
2900           rmij=1.0D0/rij
2901           r3ij=rrmij*rmij
2902           r6ij=r3ij*r3ij
2903           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2904           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2905           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2906           fac=cosa-3.0D0*cosb*cosg
2907           ev1=aaa*r6ij*r6ij
2908 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2909           if (j.eq.i+2) ev1=scal_el*ev1
2910           ev2=bbb*r6ij
2911           fac3=ael6i*r6ij
2912           fac4=ael3i*r3ij
2913           evdwij=ev1+ev2
2914           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2915           el2=fac4*fac
2916           eesij=el1+el2
2917 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2918           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2919           ees=ees+eesij
2920           evdw1=evdw1+evdwij
2921 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2922 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2923 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2924 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2925
2926           if (energy_dec) then
2927               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2928               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2929           endif
2930
2931 C
2932 C Calculate contributions to the Cartesian gradient.
2933 C
2934 #ifdef SPLITELE
2935           facvdw=-6*rrmij*(ev1+evdwij)
2936           facel=-3*rrmij*(el1+eesij)
2937           fac1=fac
2938           erij(1)=xj*rmij
2939           erij(2)=yj*rmij
2940           erij(3)=zj*rmij
2941 *
2942 * Radial derivatives. First process both termini of the fragment (i,j)
2943 *
2944           ggg(1)=facel*xj
2945           ggg(2)=facel*yj
2946           ggg(3)=facel*zj
2947 c          do k=1,3
2948 c            ghalf=0.5D0*ggg(k)
2949 c            gelc(k,i)=gelc(k,i)+ghalf
2950 c            gelc(k,j)=gelc(k,j)+ghalf
2951 c          enddo
2952 c 9/28/08 AL Gradient compotents will be summed only at the end
2953           do k=1,3
2954             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2955             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2956           enddo
2957 *
2958 * Loop over residues i+1 thru j-1.
2959 *
2960 cgrad          do k=i+1,j-1
2961 cgrad            do l=1,3
2962 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2963 cgrad            enddo
2964 cgrad          enddo
2965           ggg(1)=facvdw*xj
2966           ggg(2)=facvdw*yj
2967           ggg(3)=facvdw*zj
2968 c          do k=1,3
2969 c            ghalf=0.5D0*ggg(k)
2970 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2971 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2972 c          enddo
2973 c 9/28/08 AL Gradient compotents will be summed only at the end
2974           do k=1,3
2975             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2976             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2977           enddo
2978 *
2979 * Loop over residues i+1 thru j-1.
2980 *
2981 cgrad          do k=i+1,j-1
2982 cgrad            do l=1,3
2983 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2984 cgrad            enddo
2985 cgrad          enddo
2986 #else
2987           facvdw=ev1+evdwij
2988           facel=el1+eesij
2989           fac1=fac
2990           fac=-3*rrmij*(facvdw+facvdw+facel)
2991           erij(1)=xj*rmij
2992           erij(2)=yj*rmij
2993           erij(3)=zj*rmij
2994 *
2995 * Radial derivatives. First process both termini of the fragment (i,j)
2996 *
2997           ggg(1)=fac*xj
2998           ggg(2)=fac*yj
2999           ggg(3)=fac*zj
3000 c          do k=1,3
3001 c            ghalf=0.5D0*ggg(k)
3002 c            gelc(k,i)=gelc(k,i)+ghalf
3003 c            gelc(k,j)=gelc(k,j)+ghalf
3004 c          enddo
3005 c 9/28/08 AL Gradient compotents will be summed only at the end
3006           do k=1,3
3007             gelc_long(k,j)=gelc(k,j)+ggg(k)
3008             gelc_long(k,i)=gelc(k,i)-ggg(k)
3009           enddo
3010 *
3011 * Loop over residues i+1 thru j-1.
3012 *
3013 cgrad          do k=i+1,j-1
3014 cgrad            do l=1,3
3015 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3016 cgrad            enddo
3017 cgrad          enddo
3018 c 9/28/08 AL Gradient compotents will be summed only at the end
3019           ggg(1)=facvdw*xj
3020           ggg(2)=facvdw*yj
3021           ggg(3)=facvdw*zj
3022           do k=1,3
3023             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3024             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3025           enddo
3026 #endif
3027 *
3028 * Angular part
3029 *
3030           ecosa=2.0D0*fac3*fac1+fac4
3031           fac4=-3.0D0*fac4
3032           fac3=-6.0D0*fac3
3033           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3034           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3035           do k=1,3
3036             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3037             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3038           enddo
3039 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3040 cd   &          (dcosg(k),k=1,3)
3041           do k=1,3
3042             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3043           enddo
3044 c          do k=1,3
3045 c            ghalf=0.5D0*ggg(k)
3046 c            gelc(k,i)=gelc(k,i)+ghalf
3047 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3048 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3049 c            gelc(k,j)=gelc(k,j)+ghalf
3050 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3051 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3052 c          enddo
3053 cgrad          do k=i+1,j-1
3054 cgrad            do l=1,3
3055 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3056 cgrad            enddo
3057 cgrad          enddo
3058           do k=1,3
3059             gelc(k,i)=gelc(k,i)
3060      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3061      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3062             gelc(k,j)=gelc(k,j)
3063      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3064      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3065             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3066             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3067           enddo
3068           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3069      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3070      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3071 C
3072 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3073 C   energy of a peptide unit is assumed in the form of a second-order
3074 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3075 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3076 C   are computed for EVERY pair of non-contiguous peptide groups.
3077 C
3078           if (j.lt.nres-1) then
3079             j1=j+1
3080             j2=j-1
3081           else
3082             j1=j-1
3083             j2=j-2
3084           endif
3085           kkk=0
3086           do k=1,2
3087             do l=1,2
3088               kkk=kkk+1
3089               muij(kkk)=mu(k,i)*mu(l,j)
3090             enddo
3091           enddo
3092 cd         write (iout,*) 'EELEC: i',i,' j',j
3093 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3094 cd          write(iout,*) 'muij',muij
3095           ury=scalar(uy(1,i),erij)
3096           urz=scalar(uz(1,i),erij)
3097           vry=scalar(uy(1,j),erij)
3098           vrz=scalar(uz(1,j),erij)
3099           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3100           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3101           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3102           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3103           fac=dsqrt(-ael6i)*r3ij
3104           a22=a22*fac
3105           a23=a23*fac
3106           a32=a32*fac
3107           a33=a33*fac
3108 cd          write (iout,'(4i5,4f10.5)')
3109 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3110 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3111 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3112 cd     &      uy(:,j),uz(:,j)
3113 cd          write (iout,'(4f10.5)')
3114 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3115 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3116 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3117 cd           write (iout,'(9f10.5/)')
3118 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3119 C Derivatives of the elements of A in virtual-bond vectors
3120           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3121           do k=1,3
3122             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3123             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3124             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3125             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3126             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3127             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3128             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3129             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3130             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3131             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3132             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3133             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3134           enddo
3135 C Compute radial contributions to the gradient
3136           facr=-3.0d0*rrmij
3137           a22der=a22*facr
3138           a23der=a23*facr
3139           a32der=a32*facr
3140           a33der=a33*facr
3141           agg(1,1)=a22der*xj
3142           agg(2,1)=a22der*yj
3143           agg(3,1)=a22der*zj
3144           agg(1,2)=a23der*xj
3145           agg(2,2)=a23der*yj
3146           agg(3,2)=a23der*zj
3147           agg(1,3)=a32der*xj
3148           agg(2,3)=a32der*yj
3149           agg(3,3)=a32der*zj
3150           agg(1,4)=a33der*xj
3151           agg(2,4)=a33der*yj
3152           agg(3,4)=a33der*zj
3153 C Add the contributions coming from er
3154           fac3=-3.0d0*fac
3155           do k=1,3
3156             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3157             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3158             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3159             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3160           enddo
3161           do k=1,3
3162 C Derivatives in DC(i)
3163 cgrad            ghalf1=0.5d0*agg(k,1)
3164 cgrad            ghalf2=0.5d0*agg(k,2)
3165 cgrad            ghalf3=0.5d0*agg(k,3)
3166 cgrad            ghalf4=0.5d0*agg(k,4)
3167             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3168      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3169             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3170      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3171             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3172      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3173             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3174      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3175 C Derivatives in DC(i+1)
3176             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3177      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3178             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3179      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3180             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3181      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3182             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3183      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3184 C Derivatives in DC(j)
3185             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3186      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3187             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3188      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3189             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3190      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3191             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3192      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3193 C Derivatives in DC(j+1) or DC(nres-1)
3194             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3195      &      -3.0d0*vryg(k,3)*ury)
3196             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3197      &      -3.0d0*vrzg(k,3)*ury)
3198             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3199      &      -3.0d0*vryg(k,3)*urz)
3200             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3201      &      -3.0d0*vrzg(k,3)*urz)
3202 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3203 cgrad              do l=1,4
3204 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3205 cgrad              enddo
3206 cgrad            endif
3207           enddo
3208           acipa(1,1)=a22
3209           acipa(1,2)=a23
3210           acipa(2,1)=a32
3211           acipa(2,2)=a33
3212           a22=-a22
3213           a23=-a23
3214           do l=1,2
3215             do k=1,3
3216               agg(k,l)=-agg(k,l)
3217               aggi(k,l)=-aggi(k,l)
3218               aggi1(k,l)=-aggi1(k,l)
3219               aggj(k,l)=-aggj(k,l)
3220               aggj1(k,l)=-aggj1(k,l)
3221             enddo
3222           enddo
3223           if (j.lt.nres-1) then
3224             a22=-a22
3225             a32=-a32
3226             do l=1,3,2
3227               do k=1,3
3228                 agg(k,l)=-agg(k,l)
3229                 aggi(k,l)=-aggi(k,l)
3230                 aggi1(k,l)=-aggi1(k,l)
3231                 aggj(k,l)=-aggj(k,l)
3232                 aggj1(k,l)=-aggj1(k,l)
3233               enddo
3234             enddo
3235           else
3236             a22=-a22
3237             a23=-a23
3238             a32=-a32
3239             a33=-a33
3240             do l=1,4
3241               do k=1,3
3242                 agg(k,l)=-agg(k,l)
3243                 aggi(k,l)=-aggi(k,l)
3244                 aggi1(k,l)=-aggi1(k,l)
3245                 aggj(k,l)=-aggj(k,l)
3246                 aggj1(k,l)=-aggj1(k,l)
3247               enddo
3248             enddo
3249           endif
3250           ENDIF ! WCORR
3251           IF (wel_loc.gt.0.0d0) THEN
3252 C Contribution to the local-electrostatic energy coming from the i-j pair
3253           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3254      &     +a33*muij(4)
3255 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3256
3257           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3258      &            'eelloc',i,j,eel_loc_ij
3259
3260           eel_loc=eel_loc+eel_loc_ij
3261 C Partial derivatives in virtual-bond dihedral angles gamma
3262           if (i.gt.1)
3263      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3264      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3265      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3266           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3267      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3268      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3269 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3270           do l=1,3
3271             ggg(l)=agg(l,1)*muij(1)+
3272      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3273             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3274             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3275 cgrad            ghalf=0.5d0*ggg(l)
3276 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3277 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3278           enddo
3279 cgrad          do k=i+1,j2
3280 cgrad            do l=1,3
3281 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3282 cgrad            enddo
3283 cgrad          enddo
3284 C Remaining derivatives of eello
3285           do l=1,3
3286             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3287      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3288             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3289      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3290             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3291      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3292             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3293      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3294           enddo
3295           ENDIF
3296 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3297 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3298           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3299      &       .and. num_conti.le.maxconts) then
3300 c            write (iout,*) i,j," entered corr"
3301 C
3302 C Calculate the contact function. The ith column of the array JCONT will
3303 C contain the numbers of atoms that make contacts with the atom I (of numbers
3304 C greater than I). The arrays FACONT and GACONT will contain the values of
3305 C the contact function and its derivative.
3306 c           r0ij=1.02D0*rpp(iteli,itelj)
3307 c           r0ij=1.11D0*rpp(iteli,itelj)
3308             r0ij=2.20D0*rpp(iteli,itelj)
3309 c           r0ij=1.55D0*rpp(iteli,itelj)
3310             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3311             if (fcont.gt.0.0D0) then
3312               num_conti=num_conti+1
3313               if (num_conti.gt.maxconts) then
3314                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3315      &                         ' will skip next contacts for this conf.'
3316               else
3317                 jcont_hb(num_conti,i)=j
3318 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3319 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3320                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3321      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3322 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3323 C  terms.
3324                 d_cont(num_conti,i)=rij
3325 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3326 C     --- Electrostatic-interaction matrix ---
3327                 a_chuj(1,1,num_conti,i)=a22
3328                 a_chuj(1,2,num_conti,i)=a23
3329                 a_chuj(2,1,num_conti,i)=a32
3330                 a_chuj(2,2,num_conti,i)=a33
3331 C     --- Gradient of rij
3332                 do kkk=1,3
3333                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3334                 enddo
3335                 kkll=0
3336                 do k=1,2
3337                   do l=1,2
3338                     kkll=kkll+1
3339                     do m=1,3
3340                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3341                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3342                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3343                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3344                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3345                     enddo
3346                   enddo
3347                 enddo
3348                 ENDIF
3349                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3350 C Calculate contact energies
3351                 cosa4=4.0D0*cosa
3352                 wij=cosa-3.0D0*cosb*cosg
3353                 cosbg1=cosb+cosg
3354                 cosbg2=cosb-cosg
3355 c               fac3=dsqrt(-ael6i)/r0ij**3
3356                 fac3=dsqrt(-ael6i)*r3ij
3357 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3358                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3359                 if (ees0tmp.gt.0) then
3360                   ees0pij=dsqrt(ees0tmp)
3361                 else
3362                   ees0pij=0
3363                 endif
3364 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3365                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3366                 if (ees0tmp.gt.0) then
3367                   ees0mij=dsqrt(ees0tmp)
3368                 else
3369                   ees0mij=0
3370                 endif
3371 c               ees0mij=0.0D0
3372                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3373                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3374 C Diagnostics. Comment out or remove after debugging!
3375 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3376 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3377 c               ees0m(num_conti,i)=0.0D0
3378 C End diagnostics.
3379 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3380 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3381 C Angular derivatives of the contact function
3382                 ees0pij1=fac3/ees0pij
3383                 ees0mij1=fac3/ees0mij
3384                 fac3p=-3.0D0*fac3*rrmij
3385                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3386                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3387 c               ees0mij1=0.0D0
3388                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3389                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3390                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3391                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3392                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3393                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3394                 ecosap=ecosa1+ecosa2
3395                 ecosbp=ecosb1+ecosb2
3396                 ecosgp=ecosg1+ecosg2
3397                 ecosam=ecosa1-ecosa2
3398                 ecosbm=ecosb1-ecosb2
3399                 ecosgm=ecosg1-ecosg2
3400 C Diagnostics
3401 c               ecosap=ecosa1
3402 c               ecosbp=ecosb1
3403 c               ecosgp=ecosg1
3404 c               ecosam=0.0D0
3405 c               ecosbm=0.0D0
3406 c               ecosgm=0.0D0
3407 C End diagnostics
3408                 facont_hb(num_conti,i)=fcont
3409                 fprimcont=fprimcont/rij
3410 cd              facont_hb(num_conti,i)=1.0D0
3411 C Following line is for diagnostics.
3412 cd              fprimcont=0.0D0
3413                 do k=1,3
3414                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3415                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3416                 enddo
3417                 do k=1,3
3418                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3419                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3420                 enddo
3421                 gggp(1)=gggp(1)+ees0pijp*xj
3422                 gggp(2)=gggp(2)+ees0pijp*yj
3423                 gggp(3)=gggp(3)+ees0pijp*zj
3424                 gggm(1)=gggm(1)+ees0mijp*xj
3425                 gggm(2)=gggm(2)+ees0mijp*yj
3426                 gggm(3)=gggm(3)+ees0mijp*zj
3427 C Derivatives due to the contact function
3428                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3429                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3430                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3431                 do k=1,3
3432 c
3433 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3434 c          following the change of gradient-summation algorithm.
3435 c
3436 cgrad                  ghalfp=0.5D0*gggp(k)
3437 cgrad                  ghalfm=0.5D0*gggm(k)
3438                   gacontp_hb1(k,num_conti,i)=!ghalfp
3439      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3440      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3441                   gacontp_hb2(k,num_conti,i)=!ghalfp
3442      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3443      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3444                   gacontp_hb3(k,num_conti,i)=gggp(k)
3445                   gacontm_hb1(k,num_conti,i)=!ghalfm
3446      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3447      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3448                   gacontm_hb2(k,num_conti,i)=!ghalfm
3449      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3450      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3451                   gacontm_hb3(k,num_conti,i)=gggm(k)
3452                 enddo
3453 C Diagnostics. Comment out or remove after debugging!
3454 cdiag           do k=1,3
3455 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3456 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3457 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3458 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3459 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3460 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3461 cdiag           enddo
3462               ENDIF ! wcorr
3463               endif  ! num_conti.le.maxconts
3464             endif  ! fcont.gt.0
3465           endif    ! j.gt.i+1
3466           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3467             do k=1,4
3468               do l=1,3
3469                 ghalf=0.5d0*agg(l,k)
3470                 aggi(l,k)=aggi(l,k)+ghalf
3471                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3472                 aggj(l,k)=aggj(l,k)+ghalf
3473               enddo
3474             enddo
3475             if (j.eq.nres-1 .and. i.lt.j-2) then
3476               do k=1,4
3477                 do l=1,3
3478                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3479                 enddo
3480               enddo
3481             endif
3482           endif
3483 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3484       return
3485       end
3486 C-----------------------------------------------------------------------------
3487       subroutine eturn3(i,eello_turn3)
3488 C Third- and fourth-order contributions from turns
3489       implicit real*8 (a-h,o-z)
3490       include 'DIMENSIONS'
3491       include 'COMMON.IOUNITS'
3492       include 'COMMON.GEO'
3493       include 'COMMON.VAR'
3494       include 'COMMON.LOCAL'
3495       include 'COMMON.CHAIN'
3496       include 'COMMON.DERIV'
3497       include 'COMMON.INTERACT'
3498       include 'COMMON.CONTACTS'
3499       include 'COMMON.TORSION'
3500       include 'COMMON.VECTORS'
3501       include 'COMMON.FFIELD'
3502       include 'COMMON.CONTROL'
3503       dimension ggg(3)
3504       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3505      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3506      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3507       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3508      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3509       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3510      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3511      &    num_conti,j1,j2
3512       j=i+2
3513 c      write (iout,*) "eturn3",i,j,j1,j2
3514       a_temp(1,1)=a22
3515       a_temp(1,2)=a23
3516       a_temp(2,1)=a32
3517       a_temp(2,2)=a33
3518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3519 C
3520 C               Third-order contributions
3521 C
3522 C                 (i+2)o----(i+3)
3523 C                      | |
3524 C                      | |
3525 C                 (i+1)o----i
3526 C
3527 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3528 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3529         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3530         call transpose2(auxmat(1,1),auxmat1(1,1))
3531         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3532         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3533         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3534      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3535 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3536 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3537 cd     &    ' eello_turn3_num',4*eello_turn3_num
3538 C Derivatives in gamma(i)
3539         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3540         call transpose2(auxmat2(1,1),auxmat3(1,1))
3541         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3542         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3543 C Derivatives in gamma(i+1)
3544         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3545         call transpose2(auxmat2(1,1),auxmat3(1,1))
3546         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3547         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3548      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3549 C Cartesian derivatives
3550         do l=1,3
3551 c            ghalf1=0.5d0*agg(l,1)
3552 c            ghalf2=0.5d0*agg(l,2)
3553 c            ghalf3=0.5d0*agg(l,3)
3554 c            ghalf4=0.5d0*agg(l,4)
3555           a_temp(1,1)=aggi(l,1)!+ghalf1
3556           a_temp(1,2)=aggi(l,2)!+ghalf2
3557           a_temp(2,1)=aggi(l,3)!+ghalf3
3558           a_temp(2,2)=aggi(l,4)!+ghalf4
3559           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3560           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3561      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3562           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3563           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3564           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3565           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3566           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3567           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3568      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3569           a_temp(1,1)=aggj(l,1)!+ghalf1
3570           a_temp(1,2)=aggj(l,2)!+ghalf2
3571           a_temp(2,1)=aggj(l,3)!+ghalf3
3572           a_temp(2,2)=aggj(l,4)!+ghalf4
3573           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3574           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3575      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3576           a_temp(1,1)=aggj1(l,1)
3577           a_temp(1,2)=aggj1(l,2)
3578           a_temp(2,1)=aggj1(l,3)
3579           a_temp(2,2)=aggj1(l,4)
3580           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3581           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3582      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3583         enddo
3584       return
3585       end
3586 C-------------------------------------------------------------------------------
3587       subroutine eturn4(i,eello_turn4)
3588 C Third- and fourth-order contributions from turns
3589       implicit real*8 (a-h,o-z)
3590       include 'DIMENSIONS'
3591       include 'COMMON.IOUNITS'
3592       include 'COMMON.GEO'
3593       include 'COMMON.VAR'
3594       include 'COMMON.LOCAL'
3595       include 'COMMON.CHAIN'
3596       include 'COMMON.DERIV'
3597       include 'COMMON.INTERACT'
3598       include 'COMMON.CONTACTS'
3599       include 'COMMON.TORSION'
3600       include 'COMMON.VECTORS'
3601       include 'COMMON.FFIELD'
3602       include 'COMMON.CONTROL'
3603       dimension ggg(3)
3604       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3605      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3606      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3607       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3608      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3609       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3610      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3611      &    num_conti,j1,j2
3612       j=i+3
3613 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3614 C
3615 C               Fourth-order contributions
3616 C
3617 C                 (i+3)o----(i+4)
3618 C                     /  |
3619 C               (i+2)o   |
3620 C                     \  |
3621 C                 (i+1)o----i
3622 C
3623 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3624 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3625 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3626         a_temp(1,1)=a22
3627         a_temp(1,2)=a23
3628         a_temp(2,1)=a32
3629         a_temp(2,2)=a33
3630         iti1=itortyp(itype(i+1))
3631         iti2=itortyp(itype(i+2))
3632         iti3=itortyp(itype(i+3))
3633 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3634         call transpose2(EUg(1,1,i+1),e1t(1,1))
3635         call transpose2(Eug(1,1,i+2),e2t(1,1))
3636         call transpose2(Eug(1,1,i+3),e3t(1,1))
3637         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3638         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3639         s1=scalar2(b1(1,iti2),auxvec(1))
3640         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3641         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3642         s2=scalar2(b1(1,iti1),auxvec(1))
3643         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3644         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3645         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3646         eello_turn4=eello_turn4-(s1+s2+s3)
3647         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3648      &      'eturn4',i,j,-(s1+s2+s3)
3649 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3650 cd     &    ' eello_turn4_num',8*eello_turn4_num
3651 C Derivatives in gamma(i)
3652         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3653         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3654         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3655         s1=scalar2(b1(1,iti2),auxvec(1))
3656         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3657         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3658         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3659 C Derivatives in gamma(i+1)
3660         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3661         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3662         s2=scalar2(b1(1,iti1),auxvec(1))
3663         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3664         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3665         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3666         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3667 C Derivatives in gamma(i+2)
3668         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3669         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3670         s1=scalar2(b1(1,iti2),auxvec(1))
3671         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3672         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3673         s2=scalar2(b1(1,iti1),auxvec(1))
3674         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3675         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3676         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3677         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3678 C Cartesian derivatives
3679 C Derivatives of this turn contributions in DC(i+2)
3680         if (j.lt.nres-1) then
3681           do l=1,3
3682             a_temp(1,1)=agg(l,1)
3683             a_temp(1,2)=agg(l,2)
3684             a_temp(2,1)=agg(l,3)
3685             a_temp(2,2)=agg(l,4)
3686             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3687             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3688             s1=scalar2(b1(1,iti2),auxvec(1))
3689             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3690             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3691             s2=scalar2(b1(1,iti1),auxvec(1))
3692             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3693             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3694             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3695             ggg(l)=-(s1+s2+s3)
3696             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3697           enddo
3698         endif
3699 C Remaining derivatives of this turn contribution
3700         do l=1,3
3701           a_temp(1,1)=aggi(l,1)
3702           a_temp(1,2)=aggi(l,2)
3703           a_temp(2,1)=aggi(l,3)
3704           a_temp(2,2)=aggi(l,4)
3705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3707           s1=scalar2(b1(1,iti2),auxvec(1))
3708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3710           s2=scalar2(b1(1,iti1),auxvec(1))
3711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3714           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3715           a_temp(1,1)=aggi1(l,1)
3716           a_temp(1,2)=aggi1(l,2)
3717           a_temp(2,1)=aggi1(l,3)
3718           a_temp(2,2)=aggi1(l,4)
3719           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3720           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3721           s1=scalar2(b1(1,iti2),auxvec(1))
3722           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3723           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3724           s2=scalar2(b1(1,iti1),auxvec(1))
3725           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3726           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3727           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3728           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3729           a_temp(1,1)=aggj(l,1)
3730           a_temp(1,2)=aggj(l,2)
3731           a_temp(2,1)=aggj(l,3)
3732           a_temp(2,2)=aggj(l,4)
3733           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3734           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3735           s1=scalar2(b1(1,iti2),auxvec(1))
3736           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3737           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3738           s2=scalar2(b1(1,iti1),auxvec(1))
3739           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3740           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3741           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3742           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3743           a_temp(1,1)=aggj1(l,1)
3744           a_temp(1,2)=aggj1(l,2)
3745           a_temp(2,1)=aggj1(l,3)
3746           a_temp(2,2)=aggj1(l,4)
3747           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3748           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3749           s1=scalar2(b1(1,iti2),auxvec(1))
3750           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3751           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3752           s2=scalar2(b1(1,iti1),auxvec(1))
3753           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3754           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3755           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3756 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3757           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3758         enddo
3759       return
3760       end
3761 C-----------------------------------------------------------------------------
3762       subroutine vecpr(u,v,w)
3763       implicit real*8(a-h,o-z)
3764       dimension u(3),v(3),w(3)
3765       w(1)=u(2)*v(3)-u(3)*v(2)
3766       w(2)=-u(1)*v(3)+u(3)*v(1)
3767       w(3)=u(1)*v(2)-u(2)*v(1)
3768       return
3769       end
3770 C-----------------------------------------------------------------------------
3771       subroutine unormderiv(u,ugrad,unorm,ungrad)
3772 C This subroutine computes the derivatives of a normalized vector u, given
3773 C the derivatives computed without normalization conditions, ugrad. Returns
3774 C ungrad.
3775       implicit none
3776       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3777       double precision vec(3)
3778       double precision scalar
3779       integer i,j
3780 c      write (2,*) 'ugrad',ugrad
3781 c      write (2,*) 'u',u
3782       do i=1,3
3783         vec(i)=scalar(ugrad(1,i),u(1))
3784       enddo
3785 c      write (2,*) 'vec',vec
3786       do i=1,3
3787         do j=1,3
3788           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3789         enddo
3790       enddo
3791 c      write (2,*) 'ungrad',ungrad
3792       return
3793       end
3794 C-----------------------------------------------------------------------------
3795       subroutine escp_soft_sphere(evdw2,evdw2_14)
3796 C
3797 C This subroutine calculates the excluded-volume interaction energy between
3798 C peptide-group centers and side chains and its gradient in virtual-bond and
3799 C side-chain vectors.
3800 C
3801       implicit real*8 (a-h,o-z)
3802       include 'DIMENSIONS'
3803       include 'COMMON.GEO'
3804       include 'COMMON.VAR'
3805       include 'COMMON.LOCAL'
3806       include 'COMMON.CHAIN'
3807       include 'COMMON.DERIV'
3808       include 'COMMON.INTERACT'
3809       include 'COMMON.FFIELD'
3810       include 'COMMON.IOUNITS'
3811       include 'COMMON.CONTROL'
3812       dimension ggg(3)
3813       evdw2=0.0D0
3814       evdw2_14=0.0d0
3815       r0_scp=4.5d0
3816 cd    print '(a)','Enter ESCP'
3817 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3818       do i=iatscp_s,iatscp_e
3819         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3820         iteli=itel(i)
3821         xi=0.5D0*(c(1,i)+c(1,i+1))
3822         yi=0.5D0*(c(2,i)+c(2,i+1))
3823         zi=0.5D0*(c(3,i)+c(3,i+1))
3824
3825         do iint=1,nscp_gr(i)
3826
3827         do j=iscpstart(i,iint),iscpend(i,iint)
3828           if (itype(j).eq.21) cycle
3829           itypj=itype(j)
3830 C Uncomment following three lines for SC-p interactions
3831 c         xj=c(1,nres+j)-xi
3832 c         yj=c(2,nres+j)-yi
3833 c         zj=c(3,nres+j)-zi
3834 C Uncomment following three lines for Ca-p interactions
3835           xj=c(1,j)-xi
3836           yj=c(2,j)-yi
3837           zj=c(3,j)-zi
3838           rij=xj*xj+yj*yj+zj*zj
3839           r0ij=r0_scp
3840           r0ijsq=r0ij*r0ij
3841           if (rij.lt.r0ijsq) then
3842             evdwij=0.25d0*(rij-r0ijsq)**2
3843             fac=rij-r0ijsq
3844           else
3845             evdwij=0.0d0
3846             fac=0.0d0
3847           endif
3848           evdw2=evdw2+evdwij
3849 C
3850 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3851 C
3852           ggg(1)=xj*fac
3853           ggg(2)=yj*fac
3854           ggg(3)=zj*fac
3855 cgrad          if (j.lt.i) then
3856 cd          write (iout,*) 'j<i'
3857 C Uncomment following three lines for SC-p interactions
3858 c           do k=1,3
3859 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3860 c           enddo
3861 cgrad          else
3862 cd          write (iout,*) 'j>i'
3863 cgrad            do k=1,3
3864 cgrad              ggg(k)=-ggg(k)
3865 C Uncomment following line for SC-p interactions
3866 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3867 cgrad            enddo
3868 cgrad          endif
3869 cgrad          do k=1,3
3870 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3871 cgrad          enddo
3872 cgrad          kstart=min0(i+1,j)
3873 cgrad          kend=max0(i-1,j-1)
3874 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3875 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3876 cgrad          do k=kstart,kend
3877 cgrad            do l=1,3
3878 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3879 cgrad            enddo
3880 cgrad          enddo
3881           do k=1,3
3882             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3883             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3884           enddo
3885         enddo
3886
3887         enddo ! iint
3888       enddo ! i
3889       return
3890       end
3891 C-----------------------------------------------------------------------------
3892       subroutine escp(evdw2,evdw2_14)
3893 C
3894 C This subroutine calculates the excluded-volume interaction energy between
3895 C peptide-group centers and side chains and its gradient in virtual-bond and
3896 C side-chain vectors.
3897 C
3898       implicit real*8 (a-h,o-z)
3899       include 'DIMENSIONS'
3900       include 'COMMON.GEO'
3901       include 'COMMON.VAR'
3902       include 'COMMON.LOCAL'
3903       include 'COMMON.CHAIN'
3904       include 'COMMON.DERIV'
3905       include 'COMMON.INTERACT'
3906       include 'COMMON.FFIELD'
3907       include 'COMMON.IOUNITS'
3908       include 'COMMON.CONTROL'
3909       dimension ggg(3)
3910       evdw2=0.0D0
3911       evdw2_14=0.0d0
3912 cd    print '(a)','Enter ESCP'
3913 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3914       do i=iatscp_s,iatscp_e
3915         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3916         iteli=itel(i)
3917         xi=0.5D0*(c(1,i)+c(1,i+1))
3918         yi=0.5D0*(c(2,i)+c(2,i+1))
3919         zi=0.5D0*(c(3,i)+c(3,i+1))
3920
3921         do iint=1,nscp_gr(i)
3922
3923         do j=iscpstart(i,iint),iscpend(i,iint)
3924           itypj=itype(j)
3925           if (itypj.eq.21) cycle
3926 C Uncomment following three lines for SC-p interactions
3927 c         xj=c(1,nres+j)-xi
3928 c         yj=c(2,nres+j)-yi
3929 c         zj=c(3,nres+j)-zi
3930 C Uncomment following three lines for Ca-p interactions
3931           xj=c(1,j)-xi
3932           yj=c(2,j)-yi
3933           zj=c(3,j)-zi
3934           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3935           fac=rrij**expon2
3936           e1=fac*fac*aad(itypj,iteli)
3937           e2=fac*bad(itypj,iteli)
3938           if (iabs(j-i) .le. 2) then
3939             e1=scal14*e1
3940             e2=scal14*e2
3941             evdw2_14=evdw2_14+e1+e2
3942           endif
3943           evdwij=e1+e2
3944           evdw2=evdw2+evdwij
3945           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3946      &        'evdw2',i,j,evdwij
3947 C
3948 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3949 C
3950           fac=-(evdwij+e1)*rrij
3951           ggg(1)=xj*fac
3952           ggg(2)=yj*fac
3953           ggg(3)=zj*fac
3954 cgrad          if (j.lt.i) then
3955 cd          write (iout,*) 'j<i'
3956 C Uncomment following three lines for SC-p interactions
3957 c           do k=1,3
3958 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3959 c           enddo
3960 cgrad          else
3961 cd          write (iout,*) 'j>i'
3962 cgrad            do k=1,3
3963 cgrad              ggg(k)=-ggg(k)
3964 C Uncomment following line for SC-p interactions
3965 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3966 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3967 cgrad            enddo
3968 cgrad          endif
3969 cgrad          do k=1,3
3970 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3971 cgrad          enddo
3972 cgrad          kstart=min0(i+1,j)
3973 cgrad          kend=max0(i-1,j-1)
3974 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3975 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3976 cgrad          do k=kstart,kend
3977 cgrad            do l=1,3
3978 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3979 cgrad            enddo
3980 cgrad          enddo
3981           do k=1,3
3982             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3983             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3984           enddo
3985         enddo
3986
3987         enddo ! iint
3988       enddo ! i
3989       do i=1,nct
3990         do j=1,3
3991           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3992           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3993           gradx_scp(j,i)=expon*gradx_scp(j,i)
3994         enddo
3995       enddo
3996 C******************************************************************************
3997 C
3998 C                              N O T E !!!
3999 C
4000 C To save time the factor EXPON has been extracted from ALL components
4001 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4002 C use!
4003 C
4004 C******************************************************************************
4005       return
4006       end
4007 C--------------------------------------------------------------------------
4008       subroutine edis(ehpb)
4009 C
4010 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4011 C
4012       implicit real*8 (a-h,o-z)
4013       include 'DIMENSIONS'
4014       include 'COMMON.SBRIDGE'
4015       include 'COMMON.CHAIN'
4016       include 'COMMON.DERIV'
4017       include 'COMMON.VAR'
4018       include 'COMMON.INTERACT'
4019       include 'COMMON.IOUNITS'
4020       dimension ggg(3)
4021       ehpb=0.0D0
4022 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4023 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4024       if (link_end.eq.0) return
4025       do i=link_start,link_end
4026 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4027 C CA-CA distance used in regularization of structure.
4028         ii=ihpb(i)
4029         jj=jhpb(i)
4030 C iii and jjj point to the residues for which the distance is assigned.
4031         if (ii.gt.nres) then
4032           iii=ii-nres
4033           jjj=jj-nres
4034         else
4035           iii=ii
4036           jjj=jj
4037         endif
4038 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4039 c     &    dhpb(i),dhpb1(i),forcon(i)
4040 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4041 C    distance and angle dependent SS bond potential.
4042 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4043 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4044         if (.not.dyn_ss .and. i.le.nss) then
4045 C 15/02/13 CC dynamic SSbond - additional check
4046          if (ii.gt.nres
4047      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4048           call ssbond_ene(iii,jjj,eij)
4049           ehpb=ehpb+2*eij
4050          endif
4051 cd          write (iout,*) "eij",eij
4052         else
4053 C Calculate the distance between the two points and its difference from the
4054 C target distance.
4055           dd=dist(ii,jj)
4056             rdis=dd-dhpb(i)
4057 C Get the force constant corresponding to this distance.
4058             waga=forcon(i)
4059 C Calculate the contribution to energy.
4060             ehpb=ehpb+waga*rdis*rdis
4061 C
4062 C Evaluate gradient.
4063 C
4064             fac=waga*rdis/dd
4065 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4066 cd   &   ' waga=',waga,' fac=',fac
4067             do j=1,3
4068               ggg(j)=fac*(c(j,jj)-c(j,ii))
4069             enddo
4070 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4071 C If this is a SC-SC distance, we need to calculate the contributions to the
4072 C Cartesian gradient in the SC vectors (ghpbx).
4073           if (iii.lt.ii) then
4074           do j=1,3
4075             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4076             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4077           enddo
4078           endif
4079 cgrad        do j=iii,jjj-1
4080 cgrad          do k=1,3
4081 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4082 cgrad          enddo
4083 cgrad        enddo
4084           do k=1,3
4085             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4086             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4087           enddo
4088         endif
4089       enddo
4090       ehpb=0.5D0*ehpb
4091       return
4092       end
4093 C--------------------------------------------------------------------------
4094       subroutine ssbond_ene(i,j,eij)
4095 C
4096 C Calculate the distance and angle dependent SS-bond potential energy
4097 C using a free-energy function derived based on RHF/6-31G** ab initio
4098 C calculations of diethyl disulfide.
4099 C
4100 C A. Liwo and U. Kozlowska, 11/24/03
4101 C
4102       implicit real*8 (a-h,o-z)
4103       include 'DIMENSIONS'
4104       include 'COMMON.SBRIDGE'
4105       include 'COMMON.CHAIN'
4106       include 'COMMON.DERIV'
4107       include 'COMMON.LOCAL'
4108       include 'COMMON.INTERACT'
4109       include 'COMMON.VAR'
4110       include 'COMMON.IOUNITS'
4111       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4112       itypi=itype(i)
4113       xi=c(1,nres+i)
4114       yi=c(2,nres+i)
4115       zi=c(3,nres+i)
4116       dxi=dc_norm(1,nres+i)
4117       dyi=dc_norm(2,nres+i)
4118       dzi=dc_norm(3,nres+i)
4119 c      dsci_inv=dsc_inv(itypi)
4120       dsci_inv=vbld_inv(nres+i)
4121       itypj=itype(j)
4122 c      dscj_inv=dsc_inv(itypj)
4123       dscj_inv=vbld_inv(nres+j)
4124       xj=c(1,nres+j)-xi
4125       yj=c(2,nres+j)-yi
4126       zj=c(3,nres+j)-zi
4127       dxj=dc_norm(1,nres+j)
4128       dyj=dc_norm(2,nres+j)
4129       dzj=dc_norm(3,nres+j)
4130       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4131       rij=dsqrt(rrij)
4132       erij(1)=xj*rij
4133       erij(2)=yj*rij
4134       erij(3)=zj*rij
4135       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4136       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4137       om12=dxi*dxj+dyi*dyj+dzi*dzj
4138       do k=1,3
4139         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4140         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4141       enddo
4142       rij=1.0d0/rij
4143       deltad=rij-d0cm
4144       deltat1=1.0d0-om1
4145       deltat2=1.0d0+om2
4146       deltat12=om2-om1+2.0d0
4147       cosphi=om12-om1*om2
4148       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4149      &  +akct*deltad*deltat12
4150      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4151 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4152 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4153 c     &  " deltat12",deltat12," eij",eij
4154       ed=2*akcm*deltad+akct*deltat12
4155       pom1=akct*deltad
4156       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4157       eom1=-2*akth*deltat1-pom1-om2*pom2
4158       eom2= 2*akth*deltat2+pom1-om1*pom2
4159       eom12=pom2
4160       do k=1,3
4161         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4162         ghpbx(k,i)=ghpbx(k,i)-ggk
4163      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4164      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4165         ghpbx(k,j)=ghpbx(k,j)+ggk
4166      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4167      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4168         ghpbc(k,i)=ghpbc(k,i)-ggk
4169         ghpbc(k,j)=ghpbc(k,j)+ggk
4170       enddo
4171 C
4172 C Calculate the components of the gradient in DC and X
4173 C
4174 cgrad      do k=i,j-1
4175 cgrad        do l=1,3
4176 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4177 cgrad        enddo
4178 cgrad      enddo
4179       return
4180       end
4181 C--------------------------------------------------------------------------
4182       subroutine ebond(estr)
4183 c
4184 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4185 c
4186       implicit real*8 (a-h,o-z)
4187       include 'DIMENSIONS'
4188       include 'COMMON.LOCAL'
4189       include 'COMMON.GEO'
4190       include 'COMMON.INTERACT'
4191       include 'COMMON.DERIV'
4192       include 'COMMON.VAR'
4193       include 'COMMON.CHAIN'
4194       include 'COMMON.IOUNITS'
4195       include 'COMMON.NAMES'
4196       include 'COMMON.FFIELD'
4197       include 'COMMON.CONTROL'
4198       include 'COMMON.SETUP'
4199       double precision u(3),ud(3)
4200       estr=0.0d0
4201       estr1=0.0d0
4202       do i=ibondp_start,ibondp_end
4203         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4204           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4205           do j=1,3
4206           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4207      &      *dc(j,i-1)/vbld(i)
4208           enddo
4209           if (energy_dec) write(iout,*)
4210      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4211         else
4212         diff = vbld(i)-vbldp0
4213         if (energy_dec) write (iout,*)
4214      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4215         estr=estr+diff*diff
4216         do j=1,3
4217           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4218         enddo
4219 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4220         endif
4221       enddo
4222       estr=0.5d0*AKP*estr+estr1
4223 c
4224 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4225 c
4226       do i=ibond_start,ibond_end
4227         iti=itype(i)
4228         if (iti.ne.10 .and. iti.ne.21) then
4229           nbi=nbondterm(iti)
4230           if (nbi.eq.1) then
4231             diff=vbld(i+nres)-vbldsc0(1,iti)
4232             if (energy_dec) write (iout,*)
4233      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4234      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4235             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4236             do j=1,3
4237               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4238             enddo
4239           else
4240             do j=1,nbi
4241               diff=vbld(i+nres)-vbldsc0(j,iti)
4242               ud(j)=aksc(j,iti)*diff
4243               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4244             enddo
4245             uprod=u(1)
4246             do j=2,nbi
4247               uprod=uprod*u(j)
4248             enddo
4249             usum=0.0d0
4250             usumsqder=0.0d0
4251             do j=1,nbi
4252               uprod1=1.0d0
4253               uprod2=1.0d0
4254               do k=1,nbi
4255                 if (k.ne.j) then
4256                   uprod1=uprod1*u(k)
4257                   uprod2=uprod2*u(k)*u(k)
4258                 endif
4259               enddo
4260               usum=usum+uprod1
4261               usumsqder=usumsqder+ud(j)*uprod2
4262             enddo
4263             estr=estr+uprod/usum
4264             do j=1,3
4265              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4266             enddo
4267           endif
4268         endif
4269       enddo
4270       return
4271       end
4272 #ifdef CRYST_THETA
4273 C--------------------------------------------------------------------------
4274       subroutine ebend(etheta)
4275 C
4276 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4277 C angles gamma and its derivatives in consecutive thetas and gammas.
4278 C
4279       implicit real*8 (a-h,o-z)
4280       include 'DIMENSIONS'
4281       include 'COMMON.LOCAL'
4282       include 'COMMON.GEO'
4283       include 'COMMON.INTERACT'
4284       include 'COMMON.DERIV'
4285       include 'COMMON.VAR'
4286       include 'COMMON.CHAIN'
4287       include 'COMMON.IOUNITS'
4288       include 'COMMON.NAMES'
4289       include 'COMMON.FFIELD'
4290       include 'COMMON.CONTROL'
4291       common /calcthet/ term1,term2,termm,diffak,ratak,
4292      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4293      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4294       double precision y(2),z(2)
4295       delta=0.02d0*pi
4296 c      time11=dexp(-2*time)
4297 c      time12=1.0d0
4298       etheta=0.0D0
4299 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4300       do i=ithet_start,ithet_end
4301         if (itype(i-1).eq.21) cycle
4302 C Zero the energy function and its derivative at 0 or pi.
4303         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4304         it=itype(i-1)
4305         if (i.gt.3 .and. itype(i-2).ne.21) then
4306 #ifdef OSF
4307           phii=phi(i)
4308           if (phii.ne.phii) phii=150.0
4309 #else
4310           phii=phi(i)
4311 #endif
4312           y(1)=dcos(phii)
4313           y(2)=dsin(phii)
4314         else
4315           y(1)=0.0D0
4316           y(2)=0.0D0
4317         endif
4318         if (i.lt.nres .and. itype(i).ne.21) then
4319 #ifdef OSF
4320           phii1=phi(i+1)
4321           if (phii1.ne.phii1) phii1=150.0
4322           phii1=pinorm(phii1)
4323           z(1)=cos(phii1)
4324 #else
4325           phii1=phi(i+1)
4326           z(1)=dcos(phii1)
4327 #endif
4328           z(2)=dsin(phii1)
4329         else
4330           z(1)=0.0D0
4331           z(2)=0.0D0
4332         endif
4333 C Calculate the "mean" value of theta from the part of the distribution
4334 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4335 C In following comments this theta will be referred to as t_c.
4336         thet_pred_mean=0.0d0
4337         do k=1,2
4338           athetk=athet(k,it)
4339           bthetk=bthet(k,it)
4340           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4341         enddo
4342         dthett=thet_pred_mean*ssd
4343         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4344 C Derivatives of the "mean" values in gamma1 and gamma2.
4345         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4346         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4347         if (theta(i).gt.pi-delta) then
4348           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4349      &         E_tc0)
4350           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4351           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4352           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4353      &        E_theta)
4354           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4355      &        E_tc)
4356         else if (theta(i).lt.delta) then
4357           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4358           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4359           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4360      &        E_theta)
4361           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4362           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4363      &        E_tc)
4364         else
4365           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4366      &        E_theta,E_tc)
4367         endif
4368         etheta=etheta+ethetai
4369         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4370      &      'ebend',i,ethetai
4371         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4372         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4373         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4374       enddo
4375 C Ufff.... We've done all this!!!
4376       return
4377       end
4378 C---------------------------------------------------------------------------
4379       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4380      &     E_tc)
4381       implicit real*8 (a-h,o-z)
4382       include 'DIMENSIONS'
4383       include 'COMMON.LOCAL'
4384       include 'COMMON.IOUNITS'
4385       common /calcthet/ term1,term2,termm,diffak,ratak,
4386      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4387      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4388 C Calculate the contributions to both Gaussian lobes.
4389 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4390 C The "polynomial part" of the "standard deviation" of this part of
4391 C the distribution.
4392         sig=polthet(3,it)
4393         do j=2,0,-1
4394           sig=sig*thet_pred_mean+polthet(j,it)
4395         enddo
4396 C Derivative of the "interior part" of the "standard deviation of the"
4397 C gamma-dependent Gaussian lobe in t_c.
4398         sigtc=3*polthet(3,it)
4399         do j=2,1,-1
4400           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4401         enddo
4402         sigtc=sig*sigtc
4403 C Set the parameters of both Gaussian lobes of the distribution.
4404 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4405         fac=sig*sig+sigc0(it)
4406         sigcsq=fac+fac
4407         sigc=1.0D0/sigcsq
4408 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4409         sigsqtc=-4.0D0*sigcsq*sigtc
4410 c       print *,i,sig,sigtc,sigsqtc
4411 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4412         sigtc=-sigtc/(fac*fac)
4413 C Following variable is sigma(t_c)**(-2)
4414         sigcsq=sigcsq*sigcsq
4415         sig0i=sig0(it)
4416         sig0inv=1.0D0/sig0i**2
4417         delthec=thetai-thet_pred_mean
4418         delthe0=thetai-theta0i
4419         term1=-0.5D0*sigcsq*delthec*delthec
4420         term2=-0.5D0*sig0inv*delthe0*delthe0
4421 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4422 C NaNs in taking the logarithm. We extract the largest exponent which is added
4423 C to the energy (this being the log of the distribution) at the end of energy
4424 C term evaluation for this virtual-bond angle.
4425         if (term1.gt.term2) then
4426           termm=term1
4427           term2=dexp(term2-termm)
4428           term1=1.0d0
4429         else
4430           termm=term2
4431           term1=dexp(term1-termm)
4432           term2=1.0d0
4433         endif
4434 C The ratio between the gamma-independent and gamma-dependent lobes of
4435 C the distribution is a Gaussian function of thet_pred_mean too.
4436         diffak=gthet(2,it)-thet_pred_mean
4437         ratak=diffak/gthet(3,it)**2
4438         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4439 C Let's differentiate it in thet_pred_mean NOW.
4440         aktc=ak*ratak
4441 C Now put together the distribution terms to make complete distribution.
4442         termexp=term1+ak*term2
4443         termpre=sigc+ak*sig0i
4444 C Contribution of the bending energy from this theta is just the -log of
4445 C the sum of the contributions from the two lobes and the pre-exponential
4446 C factor. Simple enough, isn't it?
4447         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4448 C NOW the derivatives!!!
4449 C 6/6/97 Take into account the deformation.
4450         E_theta=(delthec*sigcsq*term1
4451      &       +ak*delthe0*sig0inv*term2)/termexp
4452         E_tc=((sigtc+aktc*sig0i)/termpre
4453      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4454      &       aktc*term2)/termexp)
4455       return
4456       end
4457 c-----------------------------------------------------------------------------
4458       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4459       implicit real*8 (a-h,o-z)
4460       include 'DIMENSIONS'
4461       include 'COMMON.LOCAL'
4462       include 'COMMON.IOUNITS'
4463       common /calcthet/ term1,term2,termm,diffak,ratak,
4464      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4465      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4466       delthec=thetai-thet_pred_mean
4467       delthe0=thetai-theta0i
4468 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4469       t3 = thetai-thet_pred_mean
4470       t6 = t3**2
4471       t9 = term1
4472       t12 = t3*sigcsq
4473       t14 = t12+t6*sigsqtc
4474       t16 = 1.0d0
4475       t21 = thetai-theta0i
4476       t23 = t21**2
4477       t26 = term2
4478       t27 = t21*t26
4479       t32 = termexp
4480       t40 = t32**2
4481       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4482      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4483      & *(-t12*t9-ak*sig0inv*t27)
4484       return
4485       end
4486 #else
4487 C--------------------------------------------------------------------------
4488       subroutine ebend(etheta)
4489 C
4490 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4491 C angles gamma and its derivatives in consecutive thetas and gammas.
4492 C ab initio-derived potentials from
4493 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4494 C
4495       implicit real*8 (a-h,o-z)
4496       include 'DIMENSIONS'
4497       include 'COMMON.LOCAL'
4498       include 'COMMON.GEO'
4499       include 'COMMON.INTERACT'
4500       include 'COMMON.DERIV'
4501       include 'COMMON.VAR'
4502       include 'COMMON.CHAIN'
4503       include 'COMMON.IOUNITS'
4504       include 'COMMON.NAMES'
4505       include 'COMMON.FFIELD'
4506       include 'COMMON.CONTROL'
4507       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4508      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4509      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4510      & sinph1ph2(maxdouble,maxdouble)
4511       logical lprn /.false./, lprn1 /.false./
4512       etheta=0.0D0
4513       do i=ithet_start,ithet_end
4514         if (itype(i-1).eq.21) cycle
4515         dethetai=0.0d0
4516         dephii=0.0d0
4517         dephii1=0.0d0
4518         theti2=0.5d0*theta(i)
4519         ityp2=ithetyp(itype(i-1))
4520         do k=1,nntheterm
4521           coskt(k)=dcos(k*theti2)
4522           sinkt(k)=dsin(k*theti2)
4523         enddo
4524         if (i.gt.3 .and. itype(i-2).ne.21) then
4525 #ifdef OSF
4526           phii=phi(i)
4527           if (phii.ne.phii) phii=150.0
4528 #else
4529           phii=phi(i)
4530 #endif
4531           ityp1=ithetyp(itype(i-2))
4532           do k=1,nsingle
4533             cosph1(k)=dcos(k*phii)
4534             sinph1(k)=dsin(k*phii)
4535           enddo
4536         else
4537           phii=0.0d0
4538           ityp1=nthetyp+1
4539           do k=1,nsingle
4540             cosph1(k)=0.0d0
4541             sinph1(k)=0.0d0
4542           enddo
4543         endif
4544         if (i.lt.nres .and. itype(i).ne.21) then
4545 #ifdef OSF
4546           phii1=phi(i+1)
4547           if (phii1.ne.phii1) phii1=150.0
4548           phii1=pinorm(phii1)
4549 #else
4550           phii1=phi(i+1)
4551 #endif
4552           ityp3=ithetyp(itype(i))
4553           do k=1,nsingle
4554             cosph2(k)=dcos(k*phii1)
4555             sinph2(k)=dsin(k*phii1)
4556           enddo
4557         else
4558           phii1=0.0d0
4559           ityp3=nthetyp+1
4560           do k=1,nsingle
4561             cosph2(k)=0.0d0
4562             sinph2(k)=0.0d0
4563           enddo
4564         endif
4565         ethetai=aa0thet(ityp1,ityp2,ityp3)
4566         do k=1,ndouble
4567           do l=1,k-1
4568             ccl=cosph1(l)*cosph2(k-l)
4569             ssl=sinph1(l)*sinph2(k-l)
4570             scl=sinph1(l)*cosph2(k-l)
4571             csl=cosph1(l)*sinph2(k-l)
4572             cosph1ph2(l,k)=ccl-ssl
4573             cosph1ph2(k,l)=ccl+ssl
4574             sinph1ph2(l,k)=scl+csl
4575             sinph1ph2(k,l)=scl-csl
4576           enddo
4577         enddo
4578         if (lprn) then
4579         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4580      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4581         write (iout,*) "coskt and sinkt"
4582         do k=1,nntheterm
4583           write (iout,*) k,coskt(k),sinkt(k)
4584         enddo
4585         endif
4586         do k=1,ntheterm
4587           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4588           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4589      &      *coskt(k)
4590           if (lprn)
4591      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4592      &     " ethetai",ethetai
4593         enddo
4594         if (lprn) then
4595         write (iout,*) "cosph and sinph"
4596         do k=1,nsingle
4597           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4598         enddo
4599         write (iout,*) "cosph1ph2 and sinph2ph2"
4600         do k=2,ndouble
4601           do l=1,k-1
4602             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4603      &         sinph1ph2(l,k),sinph1ph2(k,l)
4604           enddo
4605         enddo
4606         write(iout,*) "ethetai",ethetai
4607         endif
4608         do m=1,ntheterm2
4609           do k=1,nsingle
4610             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4611      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4612      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4613      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4614             ethetai=ethetai+sinkt(m)*aux
4615             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4616             dephii=dephii+k*sinkt(m)*(
4617      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4618      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4619             dephii1=dephii1+k*sinkt(m)*(
4620      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4621      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4622             if (lprn)
4623      &      write (iout,*) "m",m," k",k," bbthet",
4624      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4625      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4626      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4627      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4628           enddo
4629         enddo
4630         if (lprn)
4631      &  write(iout,*) "ethetai",ethetai
4632         do m=1,ntheterm3
4633           do k=2,ndouble
4634             do l=1,k-1
4635               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4636      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4637      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4638      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4639               ethetai=ethetai+sinkt(m)*aux
4640               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4641               dephii=dephii+l*sinkt(m)*(
4642      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4643      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4644      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4645      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4646               dephii1=dephii1+(k-l)*sinkt(m)*(
4647      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4648      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4649      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4650      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4651               if (lprn) then
4652               write (iout,*) "m",m," k",k," l",l," ffthet",
4653      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4654      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4655      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4656      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4657               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4658      &            cosph1ph2(k,l)*sinkt(m),
4659      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4660               endif
4661             enddo
4662           enddo
4663         enddo
4664 10      continue
4665         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4666      &   i,theta(i)*rad2deg,phii*rad2deg,
4667      &   phii1*rad2deg,ethetai
4668         etheta=etheta+ethetai
4669         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4670         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4671         gloc(nphi+i-2,icg)=wang*dethetai
4672       enddo
4673       return
4674       end
4675 #endif
4676 #ifdef CRYST_SC
4677 c-----------------------------------------------------------------------------
4678       subroutine esc(escloc)
4679 C Calculate the local energy of a side chain and its derivatives in the
4680 C corresponding virtual-bond valence angles THETA and the spherical angles
4681 C ALPHA and OMEGA.
4682       implicit real*8 (a-h,o-z)
4683       include 'DIMENSIONS'
4684       include 'COMMON.GEO'
4685       include 'COMMON.LOCAL'
4686       include 'COMMON.VAR'
4687       include 'COMMON.INTERACT'
4688       include 'COMMON.DERIV'
4689       include 'COMMON.CHAIN'
4690       include 'COMMON.IOUNITS'
4691       include 'COMMON.NAMES'
4692       include 'COMMON.FFIELD'
4693       include 'COMMON.CONTROL'
4694       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4695      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4696       common /sccalc/ time11,time12,time112,theti,it,nlobit
4697       delta=0.02d0*pi
4698       escloc=0.0D0
4699 c     write (iout,'(a)') 'ESC'
4700       do i=loc_start,loc_end
4701         it=itype(i)
4702         if (it.eq.21) cycle
4703         if (it.eq.10) goto 1
4704         nlobit=nlob(it)
4705 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4706 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4707         theti=theta(i+1)-pipol
4708         x(1)=dtan(theti)
4709         x(2)=alph(i)
4710         x(3)=omeg(i)
4711
4712         if (x(2).gt.pi-delta) then
4713           xtemp(1)=x(1)
4714           xtemp(2)=pi-delta
4715           xtemp(3)=x(3)
4716           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4717           xtemp(2)=pi
4718           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4719           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4720      &        escloci,dersc(2))
4721           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4722      &        ddersc0(1),dersc(1))
4723           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4724      &        ddersc0(3),dersc(3))
4725           xtemp(2)=pi-delta
4726           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4727           xtemp(2)=pi
4728           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4729           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4730      &            dersc0(2),esclocbi,dersc02)
4731           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4732      &            dersc12,dersc01)
4733           call splinthet(x(2),0.5d0*delta,ss,ssd)
4734           dersc0(1)=dersc01
4735           dersc0(2)=dersc02
4736           dersc0(3)=0.0d0
4737           do k=1,3
4738             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4739           enddo
4740           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4741 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4742 c    &             esclocbi,ss,ssd
4743           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4744 c         escloci=esclocbi
4745 c         write (iout,*) escloci
4746         else if (x(2).lt.delta) then
4747           xtemp(1)=x(1)
4748           xtemp(2)=delta
4749           xtemp(3)=x(3)
4750           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4751           xtemp(2)=0.0d0
4752           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4753           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4754      &        escloci,dersc(2))
4755           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4756      &        ddersc0(1),dersc(1))
4757           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4758      &        ddersc0(3),dersc(3))
4759           xtemp(2)=delta
4760           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4761           xtemp(2)=0.0d0
4762           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4763           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4764      &            dersc0(2),esclocbi,dersc02)
4765           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4766      &            dersc12,dersc01)
4767           dersc0(1)=dersc01
4768           dersc0(2)=dersc02
4769           dersc0(3)=0.0d0
4770           call splinthet(x(2),0.5d0*delta,ss,ssd)
4771           do k=1,3
4772             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4773           enddo
4774           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4775 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4776 c    &             esclocbi,ss,ssd
4777           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4778 c         write (iout,*) escloci
4779         else
4780           call enesc(x,escloci,dersc,ddummy,.false.)
4781         endif
4782
4783         escloc=escloc+escloci
4784         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4785      &     'escloc',i,escloci
4786 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4787
4788         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4789      &   wscloc*dersc(1)
4790         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4791         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4792     1   continue
4793       enddo
4794       return
4795       end
4796 C---------------------------------------------------------------------------
4797       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4798       implicit real*8 (a-h,o-z)
4799       include 'DIMENSIONS'
4800       include 'COMMON.GEO'
4801       include 'COMMON.LOCAL'
4802       include 'COMMON.IOUNITS'
4803       common /sccalc/ time11,time12,time112,theti,it,nlobit
4804       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4805       double precision contr(maxlob,-1:1)
4806       logical mixed
4807 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4808         escloc_i=0.0D0
4809         do j=1,3
4810           dersc(j)=0.0D0
4811           if (mixed) ddersc(j)=0.0d0
4812         enddo
4813         x3=x(3)
4814
4815 C Because of periodicity of the dependence of the SC energy in omega we have
4816 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4817 C To avoid underflows, first compute & store the exponents.
4818
4819         do iii=-1,1
4820
4821           x(3)=x3+iii*dwapi
4822
4823           do j=1,nlobit
4824             do k=1,3
4825               z(k)=x(k)-censc(k,j,it)
4826             enddo
4827             do k=1,3
4828               Axk=0.0D0
4829               do l=1,3
4830                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4831               enddo
4832               Ax(k,j,iii)=Axk
4833             enddo
4834             expfac=0.0D0
4835             do k=1,3
4836               expfac=expfac+Ax(k,j,iii)*z(k)
4837             enddo
4838             contr(j,iii)=expfac
4839           enddo ! j
4840
4841         enddo ! iii
4842
4843         x(3)=x3
4844 C As in the case of ebend, we want to avoid underflows in exponentiation and
4845 C subsequent NaNs and INFs in energy calculation.
4846 C Find the largest exponent
4847         emin=contr(1,-1)
4848         do iii=-1,1
4849           do j=1,nlobit
4850             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4851           enddo
4852         enddo
4853         emin=0.5D0*emin
4854 cd      print *,'it=',it,' emin=',emin
4855
4856 C Compute the contribution to SC energy and derivatives
4857         do iii=-1,1
4858
4859           do j=1,nlobit
4860 #ifdef OSF
4861             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4862             if(adexp.ne.adexp) adexp=1.0
4863             expfac=dexp(adexp)
4864 #else
4865             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4866 #endif
4867 cd          print *,'j=',j,' expfac=',expfac
4868             escloc_i=escloc_i+expfac
4869             do k=1,3
4870               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4871             enddo
4872             if (mixed) then
4873               do k=1,3,2
4874                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4875      &            +gaussc(k,2,j,it))*expfac
4876               enddo
4877             endif
4878           enddo
4879
4880         enddo ! iii
4881
4882         dersc(1)=dersc(1)/cos(theti)**2
4883         ddersc(1)=ddersc(1)/cos(theti)**2
4884         ddersc(3)=ddersc(3)
4885
4886         escloci=-(dlog(escloc_i)-emin)
4887         do j=1,3
4888           dersc(j)=dersc(j)/escloc_i
4889         enddo
4890         if (mixed) then
4891           do j=1,3,2
4892             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4893           enddo
4894         endif
4895       return
4896       end
4897 C------------------------------------------------------------------------------
4898       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4899       implicit real*8 (a-h,o-z)
4900       include 'DIMENSIONS'
4901       include 'COMMON.GEO'
4902       include 'COMMON.LOCAL'
4903       include 'COMMON.IOUNITS'
4904       common /sccalc/ time11,time12,time112,theti,it,nlobit
4905       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4906       double precision contr(maxlob)
4907       logical mixed
4908
4909       escloc_i=0.0D0
4910
4911       do j=1,3
4912         dersc(j)=0.0D0
4913       enddo
4914
4915       do j=1,nlobit
4916         do k=1,2
4917           z(k)=x(k)-censc(k,j,it)
4918         enddo
4919         z(3)=dwapi
4920         do k=1,3
4921           Axk=0.0D0
4922           do l=1,3
4923             Axk=Axk+gaussc(l,k,j,it)*z(l)
4924           enddo
4925           Ax(k,j)=Axk
4926         enddo
4927         expfac=0.0D0
4928         do k=1,3
4929           expfac=expfac+Ax(k,j)*z(k)
4930         enddo
4931         contr(j)=expfac
4932       enddo ! j
4933
4934 C As in the case of ebend, we want to avoid underflows in exponentiation and
4935 C subsequent NaNs and INFs in energy calculation.
4936 C Find the largest exponent
4937       emin=contr(1)
4938       do j=1,nlobit
4939         if (emin.gt.contr(j)) emin=contr(j)
4940       enddo
4941       emin=0.5D0*emin
4942
4943 C Compute the contribution to SC energy and derivatives
4944
4945       dersc12=0.0d0
4946       do j=1,nlobit
4947         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4948         escloc_i=escloc_i+expfac
4949         do k=1,2
4950           dersc(k)=dersc(k)+Ax(k,j)*expfac
4951         enddo
4952         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4953      &            +gaussc(1,2,j,it))*expfac
4954         dersc(3)=0.0d0
4955       enddo
4956
4957       dersc(1)=dersc(1)/cos(theti)**2
4958       dersc12=dersc12/cos(theti)**2
4959       escloci=-(dlog(escloc_i)-emin)
4960       do j=1,2
4961         dersc(j)=dersc(j)/escloc_i
4962       enddo
4963       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4964       return
4965       end
4966 #else
4967 c----------------------------------------------------------------------------------
4968       subroutine esc(escloc)
4969 C Calculate the local energy of a side chain and its derivatives in the
4970 C corresponding virtual-bond valence angles THETA and the spherical angles
4971 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4972 C added by Urszula Kozlowska. 07/11/2007
4973 C
4974       implicit real*8 (a-h,o-z)
4975       include 'DIMENSIONS'
4976       include 'COMMON.GEO'
4977       include 'COMMON.LOCAL'
4978       include 'COMMON.VAR'
4979       include 'COMMON.SCROT'
4980       include 'COMMON.INTERACT'
4981       include 'COMMON.DERIV'
4982       include 'COMMON.CHAIN'
4983       include 'COMMON.IOUNITS'
4984       include 'COMMON.NAMES'
4985       include 'COMMON.FFIELD'
4986       include 'COMMON.CONTROL'
4987       include 'COMMON.VECTORS'
4988       double precision x_prime(3),y_prime(3),z_prime(3)
4989      &    , sumene,dsc_i,dp2_i,x(65),
4990      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4991      &    de_dxx,de_dyy,de_dzz,de_dt
4992       double precision s1_t,s1_6_t,s2_t,s2_6_t
4993       double precision
4994      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4995      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4996      & dt_dCi(3),dt_dCi1(3)
4997       common /sccalc/ time11,time12,time112,theti,it,nlobit
4998       delta=0.02d0*pi
4999       escloc=0.0D0
5000       do i=loc_start,loc_end
5001         if (itype(i).eq.21) cycle
5002         costtab(i+1) =dcos(theta(i+1))
5003         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5004         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5005         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5006         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5007         cosfac=dsqrt(cosfac2)
5008         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5009         sinfac=dsqrt(sinfac2)
5010         it=itype(i)
5011         if (it.eq.10) goto 1
5012 c
5013 C  Compute the axes of tghe local cartesian coordinates system; store in
5014 c   x_prime, y_prime and z_prime
5015 c
5016         do j=1,3
5017           x_prime(j) = 0.00
5018           y_prime(j) = 0.00
5019           z_prime(j) = 0.00
5020         enddo
5021 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5022 C     &   dc_norm(3,i+nres)
5023         do j = 1,3
5024           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5025           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5026         enddo
5027         do j = 1,3
5028           z_prime(j) = -uz(j,i-1)
5029         enddo
5030 c       write (2,*) "i",i
5031 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5032 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5033 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5034 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5035 c      & " xy",scalar(x_prime(1),y_prime(1)),
5036 c      & " xz",scalar(x_prime(1),z_prime(1)),
5037 c      & " yy",scalar(y_prime(1),y_prime(1)),
5038 c      & " yz",scalar(y_prime(1),z_prime(1)),
5039 c      & " zz",scalar(z_prime(1),z_prime(1))
5040 c
5041 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5042 C to local coordinate system. Store in xx, yy, zz.
5043 c
5044         xx=0.0d0
5045         yy=0.0d0
5046         zz=0.0d0
5047         do j = 1,3
5048           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5049           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5050           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5051         enddo
5052
5053         xxtab(i)=xx
5054         yytab(i)=yy
5055         zztab(i)=zz
5056 C
5057 C Compute the energy of the ith side cbain
5058 C
5059 c        write (2,*) "xx",xx," yy",yy," zz",zz
5060         it=itype(i)
5061         do j = 1,65
5062           x(j) = sc_parmin(j,it)
5063         enddo
5064 #ifdef CHECK_COORD
5065 Cc diagnostics - remove later
5066         xx1 = dcos(alph(2))
5067         yy1 = dsin(alph(2))*dcos(omeg(2))
5068         zz1 = -dsin(alph(2))*dsin(omeg(2))
5069         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5070      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5071      &    xx1,yy1,zz1
5072 C,"  --- ", xx_w,yy_w,zz_w
5073 c end diagnostics
5074 #endif
5075         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5076      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5077      &   + x(10)*yy*zz
5078         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5079      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5080      & + x(20)*yy*zz
5081         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5082      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5083      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5084      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5085      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5086      &  +x(40)*xx*yy*zz
5087         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5088      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5089      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5090      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5091      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5092      &  +x(60)*xx*yy*zz
5093         dsc_i   = 0.743d0+x(61)
5094         dp2_i   = 1.9d0+x(62)
5095         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5096      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5097         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5098      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5099         s1=(1+x(63))/(0.1d0 + dscp1)
5100         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5101         s2=(1+x(65))/(0.1d0 + dscp2)
5102         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5103         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5104      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5105 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5106 c     &   sumene4,
5107 c     &   dscp1,dscp2,sumene
5108 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5109         escloc = escloc + sumene
5110 c        write (2,*) "i",i," escloc",sumene,escloc
5111 #ifdef DEBUG
5112 C
5113 C This section to check the numerical derivatives of the energy of ith side
5114 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5115 C #define DEBUG in the code to turn it on.
5116 C
5117         write (2,*) "sumene               =",sumene
5118         aincr=1.0d-7
5119         xxsave=xx
5120         xx=xx+aincr
5121         write (2,*) xx,yy,zz
5122         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5123         de_dxx_num=(sumenep-sumene)/aincr
5124         xx=xxsave
5125         write (2,*) "xx+ sumene from enesc=",sumenep
5126         yysave=yy
5127         yy=yy+aincr
5128         write (2,*) xx,yy,zz
5129         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5130         de_dyy_num=(sumenep-sumene)/aincr
5131         yy=yysave
5132         write (2,*) "yy+ sumene from enesc=",sumenep
5133         zzsave=zz
5134         zz=zz+aincr
5135         write (2,*) xx,yy,zz
5136         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5137         de_dzz_num=(sumenep-sumene)/aincr
5138         zz=zzsave
5139         write (2,*) "zz+ sumene from enesc=",sumenep
5140         costsave=cost2tab(i+1)
5141         sintsave=sint2tab(i+1)
5142         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5143         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5144         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5145         de_dt_num=(sumenep-sumene)/aincr
5146         write (2,*) " t+ sumene from enesc=",sumenep
5147         cost2tab(i+1)=costsave
5148         sint2tab(i+1)=sintsave
5149 C End of diagnostics section.
5150 #endif
5151 C
5152 C Compute the gradient of esc
5153 C
5154         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5155         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5156         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5157         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5158         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5159         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5160         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5161         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5162         pom1=(sumene3*sint2tab(i+1)+sumene1)
5163      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5164         pom2=(sumene4*cost2tab(i+1)+sumene2)
5165      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5166         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5167         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5168      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5169      &  +x(40)*yy*zz
5170         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5171         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5172      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5173      &  +x(60)*yy*zz
5174         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5175      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5176      &        +(pom1+pom2)*pom_dx
5177 #ifdef DEBUG
5178         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5179 #endif
5180 C
5181         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5182         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5183      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5184      &  +x(40)*xx*zz
5185         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5186         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5187      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5188      &  +x(59)*zz**2 +x(60)*xx*zz
5189         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5190      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5191      &        +(pom1-pom2)*pom_dy
5192 #ifdef DEBUG
5193         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5194 #endif
5195 C
5196         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5197      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5198      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5199      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5200      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5201      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5202      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5203      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5204 #ifdef DEBUG
5205         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5206 #endif
5207 C
5208         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5209      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5210      &  +pom1*pom_dt1+pom2*pom_dt2
5211 #ifdef DEBUG
5212         write(2,*), "de_dt = ", de_dt,de_dt_num
5213 #endif
5214 c
5215 C
5216        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5217        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5218        cosfac2xx=cosfac2*xx
5219        sinfac2yy=sinfac2*yy
5220        do k = 1,3
5221          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5222      &      vbld_inv(i+1)
5223          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5224      &      vbld_inv(i)
5225          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5226          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5227 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5228 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5229 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5230 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5231          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5232          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5233          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5234          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5235          dZZ_Ci1(k)=0.0d0
5236          dZZ_Ci(k)=0.0d0
5237          do j=1,3
5238            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5239            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5240          enddo
5241
5242          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5243          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5244          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5245 c
5246          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5247          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5248        enddo
5249
5250        do k=1,3
5251          dXX_Ctab(k,i)=dXX_Ci(k)
5252          dXX_C1tab(k,i)=dXX_Ci1(k)
5253          dYY_Ctab(k,i)=dYY_Ci(k)
5254          dYY_C1tab(k,i)=dYY_Ci1(k)
5255          dZZ_Ctab(k,i)=dZZ_Ci(k)
5256          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5257          dXX_XYZtab(k,i)=dXX_XYZ(k)
5258          dYY_XYZtab(k,i)=dYY_XYZ(k)
5259          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5260        enddo
5261
5262        do k = 1,3
5263 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5264 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5265 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5266 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5267 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5268 c     &    dt_dci(k)
5269 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5270 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5271          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5272      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5273          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5274      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5275          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5276      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5277        enddo
5278 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5279 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5280
5281 C to check gradient call subroutine check_grad
5282
5283     1 continue
5284       enddo
5285       return
5286       end
5287 c------------------------------------------------------------------------------
5288       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5289       implicit none
5290       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5291      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5292       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5293      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5294      &   + x(10)*yy*zz
5295       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5296      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5297      & + x(20)*yy*zz
5298       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5299      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5300      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5301      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5302      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5303      &  +x(40)*xx*yy*zz
5304       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5305      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5306      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5307      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5308      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5309      &  +x(60)*xx*yy*zz
5310       dsc_i   = 0.743d0+x(61)
5311       dp2_i   = 1.9d0+x(62)
5312       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5313      &          *(xx*cost2+yy*sint2))
5314       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5315      &          *(xx*cost2-yy*sint2))
5316       s1=(1+x(63))/(0.1d0 + dscp1)
5317       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5318       s2=(1+x(65))/(0.1d0 + dscp2)
5319       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5320       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5321      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5322       enesc=sumene
5323       return
5324       end
5325 #endif
5326 c------------------------------------------------------------------------------
5327       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5328 C
5329 C This procedure calculates two-body contact function g(rij) and its derivative:
5330 C
5331 C           eps0ij                                     !       x < -1
5332 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5333 C            0                                         !       x > 1
5334 C
5335 C where x=(rij-r0ij)/delta
5336 C
5337 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5338 C
5339       implicit none
5340       double precision rij,r0ij,eps0ij,fcont,fprimcont
5341       double precision x,x2,x4,delta
5342 c     delta=0.02D0*r0ij
5343 c      delta=0.2D0*r0ij
5344       x=(rij-r0ij)/delta
5345       if (x.lt.-1.0D0) then
5346         fcont=eps0ij
5347         fprimcont=0.0D0
5348       else if (x.le.1.0D0) then
5349         x2=x*x
5350         x4=x2*x2
5351         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5352         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5353       else
5354         fcont=0.0D0
5355         fprimcont=0.0D0
5356       endif
5357       return
5358       end
5359 c------------------------------------------------------------------------------
5360       subroutine splinthet(theti,delta,ss,ssder)
5361       implicit real*8 (a-h,o-z)
5362       include 'DIMENSIONS'
5363       include 'COMMON.VAR'
5364       include 'COMMON.GEO'
5365       thetup=pi-delta
5366       thetlow=delta
5367       if (theti.gt.pipol) then
5368         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5369       else
5370         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5371         ssder=-ssder
5372       endif
5373       return
5374       end
5375 c------------------------------------------------------------------------------
5376       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5377       implicit none
5378       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5379       double precision ksi,ksi2,ksi3,a1,a2,a3
5380       a1=fprim0*delta/(f1-f0)
5381       a2=3.0d0-2.0d0*a1
5382       a3=a1-2.0d0
5383       ksi=(x-x0)/delta
5384       ksi2=ksi*ksi
5385       ksi3=ksi2*ksi
5386       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5387       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5388       return
5389       end
5390 c------------------------------------------------------------------------------
5391       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5392       implicit none
5393       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5394       double precision ksi,ksi2,ksi3,a1,a2,a3
5395       ksi=(x-x0)/delta
5396       ksi2=ksi*ksi
5397       ksi3=ksi2*ksi
5398       a1=fprim0x*delta
5399       a2=3*(f1x-f0x)-2*fprim0x*delta
5400       a3=fprim0x*delta-2*(f1x-f0x)
5401       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5402       return
5403       end
5404 C-----------------------------------------------------------------------------
5405 #ifdef CRYST_TOR
5406 C-----------------------------------------------------------------------------
5407       subroutine etor(etors,edihcnstr)
5408       implicit real*8 (a-h,o-z)
5409       include 'DIMENSIONS'
5410       include 'COMMON.VAR'
5411       include 'COMMON.GEO'
5412       include 'COMMON.LOCAL'
5413       include 'COMMON.TORSION'
5414       include 'COMMON.INTERACT'
5415       include 'COMMON.DERIV'
5416       include 'COMMON.CHAIN'
5417       include 'COMMON.NAMES'
5418       include 'COMMON.IOUNITS'
5419       include 'COMMON.FFIELD'
5420       include 'COMMON.TORCNSTR'
5421       include 'COMMON.CONTROL'
5422       logical lprn
5423 C Set lprn=.true. for debugging
5424       lprn=.false.
5425 c      lprn=.true.
5426       etors=0.0D0
5427       do i=iphi_start,iphi_end
5428       etors_ii=0.0D0
5429         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5430      &      .or. itype(i).eq.21) cycle
5431         itori=itortyp(itype(i-2))
5432         itori1=itortyp(itype(i-1))
5433         phii=phi(i)
5434         gloci=0.0D0
5435 C Proline-Proline pair is a special case...
5436         if (itori.eq.3 .and. itori1.eq.3) then
5437           if (phii.gt.-dwapi3) then
5438             cosphi=dcos(3*phii)
5439             fac=1.0D0/(1.0D0-cosphi)
5440             etorsi=v1(1,3,3)*fac
5441             etorsi=etorsi+etorsi
5442             etors=etors+etorsi-v1(1,3,3)
5443             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5444             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5445           endif
5446           do j=1,3
5447             v1ij=v1(j+1,itori,itori1)
5448             v2ij=v2(j+1,itori,itori1)
5449             cosphi=dcos(j*phii)
5450             sinphi=dsin(j*phii)
5451             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5452             if (energy_dec) etors_ii=etors_ii+
5453      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5454             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5455           enddo
5456         else
5457           do j=1,nterm_old
5458             v1ij=v1(j,itori,itori1)
5459             v2ij=v2(j,itori,itori1)
5460             cosphi=dcos(j*phii)
5461             sinphi=dsin(j*phii)
5462             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5463             if (energy_dec) etors_ii=etors_ii+
5464      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5465             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5466           enddo
5467         endif
5468         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5469              'etor',i,etors_ii
5470         if (lprn)
5471      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5472      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5473      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5474         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5475 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5476       enddo
5477 ! 6/20/98 - dihedral angle constraints
5478       edihcnstr=0.0d0
5479       do i=1,ndih_constr
5480         itori=idih_constr(i)
5481         phii=phi(itori)
5482         difi=phii-phi0(i)
5483         if (difi.gt.drange(i)) then
5484           difi=difi-drange(i)
5485           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5486           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5487         else if (difi.lt.-drange(i)) then
5488           difi=difi+drange(i)
5489           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5490           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5491         endif
5492 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5493 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5494       enddo
5495 !      write (iout,*) 'edihcnstr',edihcnstr
5496       return
5497       end
5498 c------------------------------------------------------------------------------
5499       subroutine etor_d(etors_d)
5500       etors_d=0.0d0
5501       return
5502       end
5503 c----------------------------------------------------------------------------
5504 #else
5505       subroutine etor(etors,edihcnstr)
5506       implicit real*8 (a-h,o-z)
5507       include 'DIMENSIONS'
5508       include 'COMMON.VAR'
5509       include 'COMMON.GEO'
5510       include 'COMMON.LOCAL'
5511       include 'COMMON.TORSION'
5512       include 'COMMON.INTERACT'
5513       include 'COMMON.DERIV'
5514       include 'COMMON.CHAIN'
5515       include 'COMMON.NAMES'
5516       include 'COMMON.IOUNITS'
5517       include 'COMMON.FFIELD'
5518       include 'COMMON.TORCNSTR'
5519       include 'COMMON.CONTROL'
5520       logical lprn
5521 C Set lprn=.true. for debugging
5522       lprn=.false.
5523 c     lprn=.true.
5524       etors=0.0D0
5525       do i=iphi_start,iphi_end
5526         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5527      &       .or. itype(i).eq.21) cycle
5528       etors_ii=0.0D0
5529         itori=itortyp(itype(i-2))
5530         itori1=itortyp(itype(i-1))
5531         phii=phi(i)
5532         gloci=0.0D0
5533 C Regular cosine and sine terms
5534         do j=1,nterm(itori,itori1)
5535           v1ij=v1(j,itori,itori1)
5536           v2ij=v2(j,itori,itori1)
5537           cosphi=dcos(j*phii)
5538           sinphi=dsin(j*phii)
5539           etors=etors+v1ij*cosphi+v2ij*sinphi
5540           if (energy_dec) etors_ii=etors_ii+
5541      &                v1ij*cosphi+v2ij*sinphi
5542           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5543         enddo
5544 C Lorentz terms
5545 C                         v1
5546 C  E = SUM ----------------------------------- - v1
5547 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5548 C
5549         cosphi=dcos(0.5d0*phii)
5550         sinphi=dsin(0.5d0*phii)
5551         do j=1,nlor(itori,itori1)
5552           vl1ij=vlor1(j,itori,itori1)
5553           vl2ij=vlor2(j,itori,itori1)
5554           vl3ij=vlor3(j,itori,itori1)
5555           pom=vl2ij*cosphi+vl3ij*sinphi
5556           pom1=1.0d0/(pom*pom+1.0d0)
5557           etors=etors+vl1ij*pom1
5558           if (energy_dec) etors_ii=etors_ii+
5559      &                vl1ij*pom1
5560           pom=-pom*pom1*pom1
5561           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5562         enddo
5563 C Subtract the constant term
5564         etors=etors-v0(itori,itori1)
5565           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5566      &         'etor',i,etors_ii-v0(itori,itori1)
5567         if (lprn)
5568      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5569      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5570      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5571         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5572 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5573       enddo
5574 ! 6/20/98 - dihedral angle constraints
5575       edihcnstr=0.0d0
5576 c      do i=1,ndih_constr
5577       do i=idihconstr_start,idihconstr_end
5578         itori=idih_constr(i)
5579         phii=phi(itori)
5580         difi=pinorm(phii-phi0(i))
5581         if (difi.gt.drange(i)) then
5582           difi=difi-drange(i)
5583           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5584           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5585         else if (difi.lt.-drange(i)) then
5586           difi=difi+drange(i)
5587           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5588           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5589         else
5590           difi=0.0
5591         endif
5592 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5593 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5594 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5595       enddo
5596 cd       write (iout,*) 'edihcnstr',edihcnstr
5597       return
5598       end
5599 c----------------------------------------------------------------------------
5600       subroutine etor_d(etors_d)
5601 C 6/23/01 Compute double torsional energy
5602       implicit real*8 (a-h,o-z)
5603       include 'DIMENSIONS'
5604       include 'COMMON.VAR'
5605       include 'COMMON.GEO'
5606       include 'COMMON.LOCAL'
5607       include 'COMMON.TORSION'
5608       include 'COMMON.INTERACT'
5609       include 'COMMON.DERIV'
5610       include 'COMMON.CHAIN'
5611       include 'COMMON.NAMES'
5612       include 'COMMON.IOUNITS'
5613       include 'COMMON.FFIELD'
5614       include 'COMMON.TORCNSTR'
5615       logical lprn
5616 C Set lprn=.true. for debugging
5617       lprn=.false.
5618 c     lprn=.true.
5619       etors_d=0.0D0
5620       do i=iphid_start,iphid_end
5621         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5622      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5623         itori=itortyp(itype(i-2))
5624         itori1=itortyp(itype(i-1))
5625         itori2=itortyp(itype(i))
5626         phii=phi(i)
5627         phii1=phi(i+1)
5628         gloci1=0.0D0
5629         gloci2=0.0D0
5630 C Regular cosine and sine terms
5631         do j=1,ntermd_1(itori,itori1,itori2)
5632           v1cij=v1c(1,j,itori,itori1,itori2)
5633           v1sij=v1s(1,j,itori,itori1,itori2)
5634           v2cij=v1c(2,j,itori,itori1,itori2)
5635           v2sij=v1s(2,j,itori,itori1,itori2)
5636           cosphi1=dcos(j*phii)
5637           sinphi1=dsin(j*phii)
5638           cosphi2=dcos(j*phii1)
5639           sinphi2=dsin(j*phii1)
5640           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5641      &     v2cij*cosphi2+v2sij*sinphi2
5642           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5643           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5644         enddo
5645         do k=2,ntermd_2(itori,itori1,itori2)
5646           do l=1,k-1
5647             v1cdij = v2c(k,l,itori,itori1,itori2)
5648             v2cdij = v2c(l,k,itori,itori1,itori2)
5649             v1sdij = v2s(k,l,itori,itori1,itori2)
5650             v2sdij = v2s(l,k,itori,itori1,itori2)
5651             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5652             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5653             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5654             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5655             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5656      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5657             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5658      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5659             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5660      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5661           enddo
5662         enddo
5663         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5664         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5665       enddo
5666       return
5667       end
5668 #endif
5669 c------------------------------------------------------------------------------
5670       subroutine eback_sc_corr(esccor)
5671 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5672 c        conformational states; temporarily implemented as differences
5673 c        between UNRES torsional potentials (dependent on three types of
5674 c        residues) and the torsional potentials dependent on all 20 types
5675 c        of residues computed from AM1  energy surfaces of terminally-blocked
5676 c        amino-acid residues.
5677       implicit real*8 (a-h,o-z)
5678       include 'DIMENSIONS'
5679       include 'COMMON.VAR'
5680       include 'COMMON.GEO'
5681       include 'COMMON.LOCAL'
5682       include 'COMMON.TORSION'
5683       include 'COMMON.SCCOR'
5684       include 'COMMON.INTERACT'
5685       include 'COMMON.DERIV'
5686       include 'COMMON.CHAIN'
5687       include 'COMMON.NAMES'
5688       include 'COMMON.IOUNITS'
5689       include 'COMMON.FFIELD'
5690       include 'COMMON.CONTROL'
5691       logical lprn
5692 C Set lprn=.true. for debugging
5693       lprn=.false.
5694 c      lprn=.true.
5695 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5696       esccor=0.0D0
5697       do i=iphi_start,iphi_end
5698         if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle
5699         esccor_ii=0.0D0
5700         itori=itype(i-2)
5701         itori1=itype(i-1)
5702         phii=phi(i)
5703         gloci=0.0D0
5704         do j=1,nterm_sccor
5705           v1ij=v1sccor(j,itori,itori1)
5706           v2ij=v2sccor(j,itori,itori1)
5707           cosphi=dcos(j*phii)
5708           sinphi=dsin(j*phii)
5709           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5710           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5711         enddo
5712         if (lprn)
5713      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5714      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5715      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5716         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5717       enddo
5718       return
5719       end
5720 c----------------------------------------------------------------------------
5721       subroutine multibody(ecorr)
5722 C This subroutine calculates multi-body contributions to energy following
5723 C the idea of Skolnick et al. If side chains I and J make a contact and
5724 C at the same time side chains I+1 and J+1 make a contact, an extra
5725 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5726       implicit real*8 (a-h,o-z)
5727       include 'DIMENSIONS'
5728       include 'COMMON.IOUNITS'
5729       include 'COMMON.DERIV'
5730       include 'COMMON.INTERACT'
5731       include 'COMMON.CONTACTS'
5732       double precision gx(3),gx1(3)
5733       logical lprn
5734
5735 C Set lprn=.true. for debugging
5736       lprn=.false.
5737
5738       if (lprn) then
5739         write (iout,'(a)') 'Contact function values:'
5740         do i=nnt,nct-2
5741           write (iout,'(i2,20(1x,i2,f10.5))')
5742      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5743         enddo
5744       endif
5745       ecorr=0.0D0
5746       do i=nnt,nct
5747         do j=1,3
5748           gradcorr(j,i)=0.0D0
5749           gradxorr(j,i)=0.0D0
5750         enddo
5751       enddo
5752       do i=nnt,nct-2
5753
5754         DO ISHIFT = 3,4
5755
5756         i1=i+ishift
5757         num_conti=num_cont(i)
5758         num_conti1=num_cont(i1)
5759         do jj=1,num_conti
5760           j=jcont(jj,i)
5761           do kk=1,num_conti1
5762             j1=jcont(kk,i1)
5763             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5764 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5765 cd   &                   ' ishift=',ishift
5766 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5767 C The system gains extra energy.
5768               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5769             endif   ! j1==j+-ishift
5770           enddo     ! kk
5771         enddo       ! jj
5772
5773         ENDDO ! ISHIFT
5774
5775       enddo         ! i
5776       return
5777       end
5778 c------------------------------------------------------------------------------
5779       double precision function esccorr(i,j,k,l,jj,kk)
5780       implicit real*8 (a-h,o-z)
5781       include 'DIMENSIONS'
5782       include 'COMMON.IOUNITS'
5783       include 'COMMON.DERIV'
5784       include 'COMMON.INTERACT'
5785       include 'COMMON.CONTACTS'
5786       double precision gx(3),gx1(3)
5787       logical lprn
5788       lprn=.false.
5789       eij=facont(jj,i)
5790       ekl=facont(kk,k)
5791 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5792 C Calculate the multi-body contribution to energy.
5793 C Calculate multi-body contributions to the gradient.
5794 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5795 cd   & k,l,(gacont(m,kk,k),m=1,3)
5796       do m=1,3
5797         gx(m) =ekl*gacont(m,jj,i)
5798         gx1(m)=eij*gacont(m,kk,k)
5799         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5800         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5801         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5802         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5803       enddo
5804       do m=i,j-1
5805         do ll=1,3
5806           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5807         enddo
5808       enddo
5809       do m=k,l-1
5810         do ll=1,3
5811           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5812         enddo
5813       enddo
5814       esccorr=-eij*ekl
5815       return
5816       end
5817 c------------------------------------------------------------------------------
5818       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5819 C This subroutine calculates multi-body contributions to hydrogen-bonding
5820       implicit real*8 (a-h,o-z)
5821       include 'DIMENSIONS'
5822       include 'COMMON.IOUNITS'
5823 #ifdef MPI
5824       include "mpif.h"
5825       parameter (max_cont=maxconts)
5826       parameter (max_dim=26)
5827       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5828       double precision zapas(max_dim,maxconts,max_fg_procs),
5829      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5830       common /przechowalnia/ zapas
5831       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5832      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5833 #endif
5834       include 'COMMON.SETUP'
5835       include 'COMMON.FFIELD'
5836       include 'COMMON.DERIV'
5837       include 'COMMON.INTERACT'
5838       include 'COMMON.CONTACTS'
5839       include 'COMMON.CONTROL'
5840       include 'COMMON.LOCAL'
5841       double precision gx(3),gx1(3),time00
5842       logical lprn,ldone
5843
5844 C Set lprn=.true. for debugging
5845       lprn=.false.
5846 #ifdef MPI
5847       n_corr=0
5848       n_corr1=0
5849       if (nfgtasks.le.1) goto 30
5850       if (lprn) then
5851         write (iout,'(a)') 'Contact function values before RECEIVE:'
5852         do i=nnt,nct-2
5853           write (iout,'(2i3,50(1x,i2,f5.2))')
5854      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5855      &    j=1,num_cont_hb(i))
5856         enddo
5857       endif
5858       call flush(iout)
5859       do i=1,ntask_cont_from
5860         ncont_recv(i)=0
5861       enddo
5862       do i=1,ntask_cont_to
5863         ncont_sent(i)=0
5864       enddo
5865 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5866 c     & ntask_cont_to
5867 C Make the list of contacts to send to send to other procesors
5868 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5869 c      call flush(iout)
5870       do i=iturn3_start,iturn3_end
5871 c        write (iout,*) "make contact list turn3",i," num_cont",
5872 c     &    num_cont_hb(i)
5873         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5874       enddo
5875       do i=iturn4_start,iturn4_end
5876 c        write (iout,*) "make contact list turn4",i," num_cont",
5877 c     &   num_cont_hb(i)
5878         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5879       enddo
5880       do ii=1,nat_sent
5881         i=iat_sent(ii)
5882 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5883 c     &    num_cont_hb(i)
5884         do j=1,num_cont_hb(i)
5885         do k=1,4
5886           jjc=jcont_hb(j,i)
5887           iproc=iint_sent_local(k,jjc,ii)
5888 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5889           if (iproc.gt.0) then
5890             ncont_sent(iproc)=ncont_sent(iproc)+1
5891             nn=ncont_sent(iproc)
5892             zapas(1,nn,iproc)=i
5893             zapas(2,nn,iproc)=jjc
5894             zapas(3,nn,iproc)=facont_hb(j,i)
5895             zapas(4,nn,iproc)=ees0p(j,i)
5896             zapas(5,nn,iproc)=ees0m(j,i)
5897             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5898             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5899             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5900             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5901             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5902             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5903             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5904             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5905             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5906             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5907             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5908             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5909             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5910             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5911             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5912             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5913             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5914             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5915             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5916             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5917             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5918           endif
5919         enddo
5920         enddo
5921       enddo
5922       if (lprn) then
5923       write (iout,*)
5924      &  "Numbers of contacts to be sent to other processors",
5925      &  (ncont_sent(i),i=1,ntask_cont_to)
5926       write (iout,*) "Contacts sent"
5927       do ii=1,ntask_cont_to
5928         nn=ncont_sent(ii)
5929         iproc=itask_cont_to(ii)
5930         write (iout,*) nn," contacts to processor",iproc,
5931      &   " of CONT_TO_COMM group"
5932         do i=1,nn
5933           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5934         enddo
5935       enddo
5936       call flush(iout)
5937       endif
5938       CorrelType=477
5939       CorrelID=fg_rank+1
5940       CorrelType1=478
5941       CorrelID1=nfgtasks+fg_rank+1
5942       ireq=0
5943 C Receive the numbers of needed contacts from other processors
5944       do ii=1,ntask_cont_from
5945         iproc=itask_cont_from(ii)
5946         ireq=ireq+1
5947         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
5948      &    FG_COMM,req(ireq),IERR)
5949       enddo
5950 c      write (iout,*) "IRECV ended"
5951 c      call flush(iout)
5952 C Send the number of contacts needed by other processors
5953       do ii=1,ntask_cont_to
5954         iproc=itask_cont_to(ii)
5955         ireq=ireq+1
5956         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
5957      &    FG_COMM,req(ireq),IERR)
5958       enddo
5959 c      write (iout,*) "ISEND ended"
5960 c      write (iout,*) "number of requests (nn)",ireq
5961       call flush(iout)
5962       if (ireq.gt.0)
5963      &  call MPI_Waitall(ireq,req,status_array,ierr)
5964 c      write (iout,*)
5965 c     &  "Numbers of contacts to be received from other processors",
5966 c     &  (ncont_recv(i),i=1,ntask_cont_from)
5967 c      call flush(iout)
5968 C Receive contacts
5969       ireq=0
5970       do ii=1,ntask_cont_from
5971         iproc=itask_cont_from(ii)
5972         nn=ncont_recv(ii)
5973 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
5974 c     &   " of CONT_TO_COMM group"
5975         call flush(iout)
5976         if (nn.gt.0) then
5977           ireq=ireq+1
5978           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
5979      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5980 c          write (iout,*) "ireq,req",ireq,req(ireq)
5981         endif
5982       enddo
5983 C Send the contacts to processors that need them
5984       do ii=1,ntask_cont_to
5985         iproc=itask_cont_to(ii)
5986         nn=ncont_sent(ii)
5987 c        write (iout,*) nn," contacts to processor",iproc,
5988 c     &   " of CONT_TO_COMM group"
5989         if (nn.gt.0) then
5990           ireq=ireq+1
5991           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
5992      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5993 c          write (iout,*) "ireq,req",ireq,req(ireq)
5994 c          do i=1,nn
5995 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5996 c          enddo
5997         endif
5998       enddo
5999 c      write (iout,*) "number of requests (contacts)",ireq
6000 c      write (iout,*) "req",(req(i),i=1,4)
6001 c      call flush(iout)
6002       if (ireq.gt.0)
6003      & call MPI_Waitall(ireq,req,status_array,ierr)
6004       do iii=1,ntask_cont_from
6005         iproc=itask_cont_from(iii)
6006         nn=ncont_recv(iii)
6007         if (lprn) then
6008         write (iout,*) "Received",nn," contacts from processor",iproc,
6009      &   " of CONT_FROM_COMM group"
6010         call flush(iout)
6011         do i=1,nn
6012           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6013         enddo
6014         call flush(iout)
6015         endif
6016         do i=1,nn
6017           ii=zapas_recv(1,i,iii)
6018 c Flag the received contacts to prevent double-counting
6019           jj=-zapas_recv(2,i,iii)
6020 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6021 c          call flush(iout)
6022           nnn=num_cont_hb(ii)+1
6023           num_cont_hb(ii)=nnn
6024           jcont_hb(nnn,ii)=jj
6025           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6026           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6027           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6028           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6029           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6030           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6031           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6032           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6033           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6034           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6035           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6036           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6037           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6038           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6039           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6040           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6041           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6042           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6043           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6044           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6045           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6046           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6047           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6048           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6049         enddo
6050       enddo
6051       call flush(iout)
6052       if (lprn) then
6053         write (iout,'(a)') 'Contact function values after receive:'
6054         do i=nnt,nct-2
6055           write (iout,'(2i3,50(1x,i3,f5.2))')
6056      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6057      &    j=1,num_cont_hb(i))
6058         enddo
6059         call flush(iout)
6060       endif
6061    30 continue
6062 #endif
6063       if (lprn) then
6064         write (iout,'(a)') 'Contact function values:'
6065         do i=nnt,nct-2
6066           write (iout,'(2i3,50(1x,i3,f5.2))')
6067      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6068      &    j=1,num_cont_hb(i))
6069         enddo
6070       endif
6071       ecorr=0.0D0
6072 C Remove the loop below after debugging !!!
6073       do i=nnt,nct
6074         do j=1,3
6075           gradcorr(j,i)=0.0D0
6076           gradxorr(j,i)=0.0D0
6077         enddo
6078       enddo
6079 C Calculate the local-electrostatic correlation terms
6080       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6081         i1=i+1
6082         num_conti=num_cont_hb(i)
6083         num_conti1=num_cont_hb(i+1)
6084         do jj=1,num_conti
6085           j=jcont_hb(jj,i)
6086           jp=iabs(j)
6087           do kk=1,num_conti1
6088             j1=jcont_hb(kk,i1)
6089             jp1=iabs(j1)
6090 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6091 c     &         ' jj=',jj,' kk=',kk
6092             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6093      &          .or. j.lt.0 .and. j1.gt.0) .and.
6094      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6095 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6096 C The system gains extra energy.
6097               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6098               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6099      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6100               n_corr=n_corr+1
6101             else if (j1.eq.j) then
6102 C Contacts I-J and I-(J+1) occur simultaneously.
6103 C The system loses extra energy.
6104 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6105             endif
6106           enddo ! kk
6107           do kk=1,num_conti
6108             j1=jcont_hb(kk,i)
6109 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6110 c    &         ' jj=',jj,' kk=',kk
6111             if (j1.eq.j+1) then
6112 C Contacts I-J and (I+1)-J occur simultaneously.
6113 C The system loses extra energy.
6114 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6115             endif ! j1==j+1
6116           enddo ! kk
6117         enddo ! jj
6118       enddo ! i
6119       return
6120       end
6121 c------------------------------------------------------------------------------
6122       subroutine add_hb_contact(ii,jj,itask)
6123       implicit real*8 (a-h,o-z)
6124       include "DIMENSIONS"
6125       include "COMMON.IOUNITS"
6126       integer max_cont
6127       integer max_dim
6128       parameter (max_cont=maxconts)
6129       parameter (max_dim=26)
6130       include "COMMON.CONTACTS"
6131       double precision zapas(max_dim,maxconts,max_fg_procs),
6132      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6133       common /przechowalnia/ zapas
6134       integer i,j,ii,jj,iproc,itask(4),nn
6135 c      write (iout,*) "itask",itask
6136       do i=1,2
6137         iproc=itask(i)
6138         if (iproc.gt.0) then
6139           do j=1,num_cont_hb(ii)
6140             jjc=jcont_hb(j,ii)
6141 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6142             if (jjc.eq.jj) then
6143               ncont_sent(iproc)=ncont_sent(iproc)+1
6144               nn=ncont_sent(iproc)
6145               zapas(1,nn,iproc)=ii
6146               zapas(2,nn,iproc)=jjc
6147               zapas(3,nn,iproc)=facont_hb(j,ii)
6148               zapas(4,nn,iproc)=ees0p(j,ii)
6149               zapas(5,nn,iproc)=ees0m(j,ii)
6150               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6151               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6152               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6153               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6154               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6155               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6156               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6157               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6158               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6159               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6160               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6161               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6162               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6163               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6164               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6165               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6166               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6167               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6168               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6169               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6170               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6171               exit
6172             endif
6173           enddo
6174         endif
6175       enddo
6176       return
6177       end
6178 c------------------------------------------------------------------------------
6179       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6180      &  n_corr1)
6181 C This subroutine calculates multi-body contributions to hydrogen-bonding
6182       implicit real*8 (a-h,o-z)
6183       include 'DIMENSIONS'
6184       include 'COMMON.IOUNITS'
6185 #ifdef MPI
6186       include "mpif.h"
6187       parameter (max_cont=maxconts)
6188       parameter (max_dim=70)
6189       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6190       double precision zapas(max_dim,maxconts,max_fg_procs),
6191      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6192       common /przechowalnia/ zapas
6193       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6194      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6195 #endif
6196       include 'COMMON.SETUP'
6197       include 'COMMON.FFIELD'
6198       include 'COMMON.DERIV'
6199       include 'COMMON.LOCAL'
6200       include 'COMMON.INTERACT'
6201       include 'COMMON.CONTACTS'
6202       include 'COMMON.CHAIN'
6203       include 'COMMON.CONTROL'
6204       double precision gx(3),gx1(3)
6205       integer num_cont_hb_old(maxres)
6206       logical lprn,ldone
6207       double precision eello4,eello5,eelo6,eello_turn6
6208       external eello4,eello5,eello6,eello_turn6
6209 C Set lprn=.true. for debugging
6210       lprn=.false.
6211       eturn6=0.0d0
6212 #ifdef MPI
6213       do i=1,nres
6214         num_cont_hb_old(i)=num_cont_hb(i)
6215       enddo
6216       n_corr=0
6217       n_corr1=0
6218       if (nfgtasks.le.1) goto 30
6219       if (lprn) then
6220         write (iout,'(a)') 'Contact function values before RECEIVE:'
6221         do i=nnt,nct-2
6222           write (iout,'(2i3,50(1x,i2,f5.2))')
6223      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6224      &    j=1,num_cont_hb(i))
6225         enddo
6226       endif
6227       call flush(iout)
6228       do i=1,ntask_cont_from
6229         ncont_recv(i)=0
6230       enddo
6231       do i=1,ntask_cont_to
6232         ncont_sent(i)=0
6233       enddo
6234 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6235 c     & ntask_cont_to
6236 C Make the list of contacts to send to send to other procesors
6237       do i=iturn3_start,iturn3_end
6238 c        write (iout,*) "make contact list turn3",i," num_cont",
6239 c     &    num_cont_hb(i)
6240         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6241       enddo
6242       do i=iturn4_start,iturn4_end
6243 c        write (iout,*) "make contact list turn4",i," num_cont",
6244 c     &   num_cont_hb(i)
6245         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6246       enddo
6247       do ii=1,nat_sent
6248         i=iat_sent(ii)
6249 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6250 c     &    num_cont_hb(i)
6251         do j=1,num_cont_hb(i)
6252         do k=1,4
6253           jjc=jcont_hb(j,i)
6254           iproc=iint_sent_local(k,jjc,ii)
6255 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6256           if (iproc.ne.0) then
6257             ncont_sent(iproc)=ncont_sent(iproc)+1
6258             nn=ncont_sent(iproc)
6259             zapas(1,nn,iproc)=i
6260             zapas(2,nn,iproc)=jjc
6261             zapas(3,nn,iproc)=d_cont(j,i)
6262             ind=3
6263             do kk=1,3
6264               ind=ind+1
6265               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6266             enddo
6267             do kk=1,2
6268               do ll=1,2
6269                 ind=ind+1
6270                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6271               enddo
6272             enddo
6273             do jj=1,5
6274               do kk=1,3
6275                 do ll=1,2
6276                   do mm=1,2
6277                     ind=ind+1
6278                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6279                   enddo
6280                 enddo
6281               enddo
6282             enddo
6283           endif
6284         enddo
6285         enddo
6286       enddo
6287       if (lprn) then
6288       write (iout,*)
6289      &  "Numbers of contacts to be sent to other processors",
6290      &  (ncont_sent(i),i=1,ntask_cont_to)
6291       write (iout,*) "Contacts sent"
6292       do ii=1,ntask_cont_to
6293         nn=ncont_sent(ii)
6294         iproc=itask_cont_to(ii)
6295         write (iout,*) nn," contacts to processor",iproc,
6296      &   " of CONT_TO_COMM group"
6297         do i=1,nn
6298           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6299         enddo
6300       enddo
6301       call flush(iout)
6302       endif
6303       CorrelType=477
6304       CorrelID=fg_rank+1
6305       CorrelType1=478
6306       CorrelID1=nfgtasks+fg_rank+1
6307       ireq=0
6308 C Receive the numbers of needed contacts from other processors
6309       do ii=1,ntask_cont_from
6310         iproc=itask_cont_from(ii)
6311         ireq=ireq+1
6312         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6313      &    FG_COMM,req(ireq),IERR)
6314       enddo
6315 c      write (iout,*) "IRECV ended"
6316 c      call flush(iout)
6317 C Send the number of contacts needed by other processors
6318       do ii=1,ntask_cont_to
6319         iproc=itask_cont_to(ii)
6320         ireq=ireq+1
6321         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6322      &    FG_COMM,req(ireq),IERR)
6323       enddo
6324 c      write (iout,*) "ISEND ended"
6325 c      write (iout,*) "number of requests (nn)",ireq
6326       call flush(iout)
6327       if (ireq.gt.0)
6328      &  call MPI_Waitall(ireq,req,status_array,ierr)
6329 c      write (iout,*)
6330 c     &  "Numbers of contacts to be received from other processors",
6331 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6332 c      call flush(iout)
6333 C Receive contacts
6334       ireq=0
6335       do ii=1,ntask_cont_from
6336         iproc=itask_cont_from(ii)
6337         nn=ncont_recv(ii)
6338 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6339 c     &   " of CONT_TO_COMM group"
6340         call flush(iout)
6341         if (nn.gt.0) then
6342           ireq=ireq+1
6343           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6344      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6345 c          write (iout,*) "ireq,req",ireq,req(ireq)
6346         endif
6347       enddo
6348 C Send the contacts to processors that need them
6349       do ii=1,ntask_cont_to
6350         iproc=itask_cont_to(ii)
6351         nn=ncont_sent(ii)
6352 c        write (iout,*) nn," contacts to processor",iproc,
6353 c     &   " of CONT_TO_COMM group"
6354         if (nn.gt.0) then
6355           ireq=ireq+1
6356           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6357      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6358 c          write (iout,*) "ireq,req",ireq,req(ireq)
6359 c          do i=1,nn
6360 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6361 c          enddo
6362         endif
6363       enddo
6364 c      write (iout,*) "number of requests (contacts)",ireq
6365 c      write (iout,*) "req",(req(i),i=1,4)
6366 c      call flush(iout)
6367       if (ireq.gt.0)
6368      & call MPI_Waitall(ireq,req,status_array,ierr)
6369       do iii=1,ntask_cont_from
6370         iproc=itask_cont_from(iii)
6371         nn=ncont_recv(iii)
6372         if (lprn) then
6373         write (iout,*) "Received",nn," contacts from processor",iproc,
6374      &   " of CONT_FROM_COMM group"
6375         call flush(iout)
6376         do i=1,nn
6377           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6378         enddo
6379         call flush(iout)
6380         endif
6381         do i=1,nn
6382           ii=zapas_recv(1,i,iii)
6383 c Flag the received contacts to prevent double-counting
6384           jj=-zapas_recv(2,i,iii)
6385 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6386 c          call flush(iout)
6387           nnn=num_cont_hb(ii)+1
6388           num_cont_hb(ii)=nnn
6389           jcont_hb(nnn,ii)=jj
6390           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6391           ind=3
6392           do kk=1,3
6393             ind=ind+1
6394             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6395           enddo
6396           do kk=1,2
6397             do ll=1,2
6398               ind=ind+1
6399               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6400             enddo
6401           enddo
6402           do jj=1,5
6403             do kk=1,3
6404               do ll=1,2
6405                 do mm=1,2
6406                   ind=ind+1
6407                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6408                 enddo
6409               enddo
6410             enddo
6411           enddo
6412         enddo
6413       enddo
6414       call flush(iout)
6415       if (lprn) then
6416         write (iout,'(a)') 'Contact function values after receive:'
6417         do i=nnt,nct-2
6418           write (iout,'(2i3,50(1x,i3,5f6.3))')
6419      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6420      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6421         enddo
6422         call flush(iout)
6423       endif
6424    30 continue
6425 #endif
6426       if (lprn) then
6427         write (iout,'(a)') 'Contact function values:'
6428         do i=nnt,nct-2
6429           write (iout,'(2i3,50(1x,i2,5f6.3))')
6430      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6431      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6432         enddo
6433       endif
6434       ecorr=0.0D0
6435       ecorr5=0.0d0
6436       ecorr6=0.0d0
6437 C Remove the loop below after debugging !!!
6438       do i=nnt,nct
6439         do j=1,3
6440           gradcorr(j,i)=0.0D0
6441           gradxorr(j,i)=0.0D0
6442         enddo
6443       enddo
6444 C Calculate the dipole-dipole interaction energies
6445       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6446       do i=iatel_s,iatel_e+1
6447         num_conti=num_cont_hb(i)
6448         do jj=1,num_conti
6449           j=jcont_hb(jj,i)
6450 #ifdef MOMENT
6451           call dipole(i,j,jj)
6452 #endif
6453         enddo
6454       enddo
6455       endif
6456 C Calculate the local-electrostatic correlation terms
6457 c                write (iout,*) "gradcorr5 in eello5 before loop"
6458 c                do iii=1,nres
6459 c                  write (iout,'(i5,3f10.5)')
6460 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6461 c                enddo
6462       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6463 c        write (iout,*) "corr loop i",i
6464         i1=i+1
6465         num_conti=num_cont_hb(i)
6466         num_conti1=num_cont_hb(i+1)
6467         do jj=1,num_conti
6468           j=jcont_hb(jj,i)
6469           jp=iabs(j)
6470           do kk=1,num_conti1
6471             j1=jcont_hb(kk,i1)
6472             jp1=iabs(j1)
6473 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6474 c     &         ' jj=',jj,' kk=',kk
6475 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6476             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6477      &          .or. j.lt.0 .and. j1.gt.0) .and.
6478      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6479 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6480 C The system gains extra energy.
6481               n_corr=n_corr+1
6482               sqd1=dsqrt(d_cont(jj,i))
6483               sqd2=dsqrt(d_cont(kk,i1))
6484               sred_geom = sqd1*sqd2
6485               IF (sred_geom.lt.cutoff_corr) THEN
6486                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6487      &            ekont,fprimcont)
6488 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6489 cd     &         ' jj=',jj,' kk=',kk
6490                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6491                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6492                 do l=1,3
6493                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6494                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6495                 enddo
6496                 n_corr1=n_corr1+1
6497 cd               write (iout,*) 'sred_geom=',sred_geom,
6498 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6499 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6500 cd               write (iout,*) "g_contij",g_contij
6501 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6502 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6503                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6504                 if (wcorr4.gt.0.0d0)
6505      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6506                   if (energy_dec.and.wcorr4.gt.0.0d0)
6507      1                 write (iout,'(a6,4i5,0pf7.3)')
6508      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6509 c                write (iout,*) "gradcorr5 before eello5"
6510 c                do iii=1,nres
6511 c                  write (iout,'(i5,3f10.5)')
6512 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6513 c                enddo
6514                 if (wcorr5.gt.0.0d0)
6515      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6516 c                write (iout,*) "gradcorr5 after eello5"
6517 c                do iii=1,nres
6518 c                  write (iout,'(i5,3f10.5)')
6519 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6520 c                enddo
6521                   if (energy_dec.and.wcorr5.gt.0.0d0)
6522      1                 write (iout,'(a6,4i5,0pf7.3)')
6523      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6524 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6525 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6526                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6527      &               .or. wturn6.eq.0.0d0))then
6528 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6529                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6530                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6531      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6532 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6533 cd     &            'ecorr6=',ecorr6
6534 cd                write (iout,'(4e15.5)') sred_geom,
6535 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6536 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6537 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6538                 else if (wturn6.gt.0.0d0
6539      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6540 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6541                   eturn6=eturn6+eello_turn6(i,jj,kk)
6542                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6543      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6544 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6545                 endif
6546               ENDIF
6547 1111          continue
6548             endif
6549           enddo ! kk
6550         enddo ! jj
6551       enddo ! i
6552       do i=1,nres
6553         num_cont_hb(i)=num_cont_hb_old(i)
6554       enddo
6555 c                write (iout,*) "gradcorr5 in eello5"
6556 c                do iii=1,nres
6557 c                  write (iout,'(i5,3f10.5)')
6558 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6559 c                enddo
6560       return
6561       end
6562 c------------------------------------------------------------------------------
6563       subroutine add_hb_contact_eello(ii,jj,itask)
6564       implicit real*8 (a-h,o-z)
6565       include "DIMENSIONS"
6566       include "COMMON.IOUNITS"
6567       integer max_cont
6568       integer max_dim
6569       parameter (max_cont=maxconts)
6570       parameter (max_dim=70)
6571       include "COMMON.CONTACTS"
6572       double precision zapas(max_dim,maxconts,max_fg_procs),
6573      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6574       common /przechowalnia/ zapas
6575       integer i,j,ii,jj,iproc,itask(4),nn
6576 c      write (iout,*) "itask",itask
6577       do i=1,2
6578         iproc=itask(i)
6579         if (iproc.gt.0) then
6580           do j=1,num_cont_hb(ii)
6581             jjc=jcont_hb(j,ii)
6582 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6583             if (jjc.eq.jj) then
6584               ncont_sent(iproc)=ncont_sent(iproc)+1
6585               nn=ncont_sent(iproc)
6586               zapas(1,nn,iproc)=ii
6587               zapas(2,nn,iproc)=jjc
6588               zapas(3,nn,iproc)=d_cont(j,ii)
6589               ind=3
6590               do kk=1,3
6591                 ind=ind+1
6592                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6593               enddo
6594               do kk=1,2
6595                 do ll=1,2
6596                   ind=ind+1
6597                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6598                 enddo
6599               enddo
6600               do jj=1,5
6601                 do kk=1,3
6602                   do ll=1,2
6603                     do mm=1,2
6604                       ind=ind+1
6605                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6606                     enddo
6607                   enddo
6608                 enddo
6609               enddo
6610               exit
6611             endif
6612           enddo
6613         endif
6614       enddo
6615       return
6616       end
6617 c------------------------------------------------------------------------------
6618       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6619       implicit real*8 (a-h,o-z)
6620       include 'DIMENSIONS'
6621       include 'COMMON.IOUNITS'
6622       include 'COMMON.DERIV'
6623       include 'COMMON.INTERACT'
6624       include 'COMMON.CONTACTS'
6625       double precision gx(3),gx1(3)
6626       logical lprn
6627       lprn=.false.
6628       eij=facont_hb(jj,i)
6629       ekl=facont_hb(kk,k)
6630       ees0pij=ees0p(jj,i)
6631       ees0pkl=ees0p(kk,k)
6632       ees0mij=ees0m(jj,i)
6633       ees0mkl=ees0m(kk,k)
6634       ekont=eij*ekl
6635       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6636 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6637 C Following 4 lines for diagnostics.
6638 cd    ees0pkl=0.0D0
6639 cd    ees0pij=1.0D0
6640 cd    ees0mkl=0.0D0
6641 cd    ees0mij=1.0D0
6642 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6643 c     & 'Contacts ',i,j,
6644 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6645 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6646 c     & 'gradcorr_long'
6647 C Calculate the multi-body contribution to energy.
6648 c      ecorr=ecorr+ekont*ees
6649 C Calculate multi-body contributions to the gradient.
6650       coeffpees0pij=coeffp*ees0pij
6651       coeffmees0mij=coeffm*ees0mij
6652       coeffpees0pkl=coeffp*ees0pkl
6653       coeffmees0mkl=coeffm*ees0mkl
6654       do ll=1,3
6655 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6656         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6657      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6658      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6659         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6660      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6661      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6662 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6663         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6664      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6665      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6666         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6667      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6668      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6669         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6670      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6671      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6672         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6673         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6674         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6675      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6676      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6677         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6678         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6679 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6680       enddo
6681 c      write (iout,*)
6682 cgrad      do m=i+1,j-1
6683 cgrad        do ll=1,3
6684 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6685 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6686 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6687 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6688 cgrad        enddo
6689 cgrad      enddo
6690 cgrad      do m=k+1,l-1
6691 cgrad        do ll=1,3
6692 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6693 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6694 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6695 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6696 cgrad        enddo
6697 cgrad      enddo
6698 c      write (iout,*) "ehbcorr",ekont*ees
6699       ehbcorr=ekont*ees
6700       return
6701       end
6702 #ifdef MOMENT
6703 C---------------------------------------------------------------------------
6704       subroutine dipole(i,j,jj)
6705       implicit real*8 (a-h,o-z)
6706       include 'DIMENSIONS'
6707       include 'COMMON.IOUNITS'
6708       include 'COMMON.CHAIN'
6709       include 'COMMON.FFIELD'
6710       include 'COMMON.DERIV'
6711       include 'COMMON.INTERACT'
6712       include 'COMMON.CONTACTS'
6713       include 'COMMON.TORSION'
6714       include 'COMMON.VAR'
6715       include 'COMMON.GEO'
6716       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6717      &  auxmat(2,2)
6718       iti1 = itortyp(itype(i+1))
6719       if (j.lt.nres-1) then
6720         itj1 = itortyp(itype(j+1))
6721       else
6722         itj1=ntortyp+1
6723       endif
6724       do iii=1,2
6725         dipi(iii,1)=Ub2(iii,i)
6726         dipderi(iii)=Ub2der(iii,i)
6727         dipi(iii,2)=b1(iii,iti1)
6728         dipj(iii,1)=Ub2(iii,j)
6729         dipderj(iii)=Ub2der(iii,j)
6730         dipj(iii,2)=b1(iii,itj1)
6731       enddo
6732       kkk=0
6733       do iii=1,2
6734         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6735         do jjj=1,2
6736           kkk=kkk+1
6737           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6738         enddo
6739       enddo
6740       do kkk=1,5
6741         do lll=1,3
6742           mmm=0
6743           do iii=1,2
6744             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6745      &        auxvec(1))
6746             do jjj=1,2
6747               mmm=mmm+1
6748               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6749             enddo
6750           enddo
6751         enddo
6752       enddo
6753       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6754       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6755       do iii=1,2
6756         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6757       enddo
6758       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6759       do iii=1,2
6760         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6761       enddo
6762       return
6763       end
6764 #endif
6765 C---------------------------------------------------------------------------
6766       subroutine calc_eello(i,j,k,l,jj,kk)
6767 C
6768 C This subroutine computes matrices and vectors needed to calculate
6769 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6770 C
6771       implicit real*8 (a-h,o-z)
6772       include 'DIMENSIONS'
6773       include 'COMMON.IOUNITS'
6774       include 'COMMON.CHAIN'
6775       include 'COMMON.DERIV'
6776       include 'COMMON.INTERACT'
6777       include 'COMMON.CONTACTS'
6778       include 'COMMON.TORSION'
6779       include 'COMMON.VAR'
6780       include 'COMMON.GEO'
6781       include 'COMMON.FFIELD'
6782       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6783      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6784       logical lprn
6785       common /kutas/ lprn
6786 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6787 cd     & ' jj=',jj,' kk=',kk
6788 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6789 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6790 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6791       do iii=1,2
6792         do jjj=1,2
6793           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6794           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6795         enddo
6796       enddo
6797       call transpose2(aa1(1,1),aa1t(1,1))
6798       call transpose2(aa2(1,1),aa2t(1,1))
6799       do kkk=1,5
6800         do lll=1,3
6801           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6802      &      aa1tder(1,1,lll,kkk))
6803           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6804      &      aa2tder(1,1,lll,kkk))
6805         enddo
6806       enddo
6807       if (l.eq.j+1) then
6808 C parallel orientation of the two CA-CA-CA frames.
6809         if (i.gt.1) then
6810           iti=itortyp(itype(i))
6811         else
6812           iti=ntortyp+1
6813         endif
6814         itk1=itortyp(itype(k+1))
6815         itj=itortyp(itype(j))
6816         if (l.lt.nres-1) then
6817           itl1=itortyp(itype(l+1))
6818         else
6819           itl1=ntortyp+1
6820         endif
6821 C A1 kernel(j+1) A2T
6822 cd        do iii=1,2
6823 cd          write (iout,'(3f10.5,5x,3f10.5)')
6824 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6825 cd        enddo
6826         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6827      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6828      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6829 C Following matrices are needed only for 6-th order cumulants
6830         IF (wcorr6.gt.0.0d0) THEN
6831         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6832      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6833      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6834         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6835      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6836      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6837      &   ADtEAderx(1,1,1,1,1,1))
6838         lprn=.false.
6839         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6840      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6841      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6842      &   ADtEA1derx(1,1,1,1,1,1))
6843         ENDIF
6844 C End 6-th order cumulants
6845 cd        lprn=.false.
6846 cd        if (lprn) then
6847 cd        write (2,*) 'In calc_eello6'
6848 cd        do iii=1,2
6849 cd          write (2,*) 'iii=',iii
6850 cd          do kkk=1,5
6851 cd            write (2,*) 'kkk=',kkk
6852 cd            do jjj=1,2
6853 cd              write (2,'(3(2f10.5),5x)')
6854 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6855 cd            enddo
6856 cd          enddo
6857 cd        enddo
6858 cd        endif
6859         call transpose2(EUgder(1,1,k),auxmat(1,1))
6860         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6861         call transpose2(EUg(1,1,k),auxmat(1,1))
6862         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6863         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6864         do iii=1,2
6865           do kkk=1,5
6866             do lll=1,3
6867               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6868      &          EAEAderx(1,1,lll,kkk,iii,1))
6869             enddo
6870           enddo
6871         enddo
6872 C A1T kernel(i+1) A2
6873         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6874      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6875      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6876 C Following matrices are needed only for 6-th order cumulants
6877         IF (wcorr6.gt.0.0d0) THEN
6878         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6879      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6880      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6881         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6882      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6883      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6884      &   ADtEAderx(1,1,1,1,1,2))
6885         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6886      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6887      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6888      &   ADtEA1derx(1,1,1,1,1,2))
6889         ENDIF
6890 C End 6-th order cumulants
6891         call transpose2(EUgder(1,1,l),auxmat(1,1))
6892         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6893         call transpose2(EUg(1,1,l),auxmat(1,1))
6894         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6895         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6896         do iii=1,2
6897           do kkk=1,5
6898             do lll=1,3
6899               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6900      &          EAEAderx(1,1,lll,kkk,iii,2))
6901             enddo
6902           enddo
6903         enddo
6904 C AEAb1 and AEAb2
6905 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6906 C They are needed only when the fifth- or the sixth-order cumulants are
6907 C indluded.
6908         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6909         call transpose2(AEA(1,1,1),auxmat(1,1))
6910         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6911         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6912         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6913         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6914         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6915         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6916         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6917         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6918         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6919         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6920         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6921         call transpose2(AEA(1,1,2),auxmat(1,1))
6922         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6923         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6924         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6925         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6926         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6927         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6928         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6929         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6930         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6931         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6932         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6933 C Calculate the Cartesian derivatives of the vectors.
6934         do iii=1,2
6935           do kkk=1,5
6936             do lll=1,3
6937               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6938               call matvec2(auxmat(1,1),b1(1,iti),
6939      &          AEAb1derx(1,lll,kkk,iii,1,1))
6940               call matvec2(auxmat(1,1),Ub2(1,i),
6941      &          AEAb2derx(1,lll,kkk,iii,1,1))
6942               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6943      &          AEAb1derx(1,lll,kkk,iii,2,1))
6944               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6945      &          AEAb2derx(1,lll,kkk,iii,2,1))
6946               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6947               call matvec2(auxmat(1,1),b1(1,itj),
6948      &          AEAb1derx(1,lll,kkk,iii,1,2))
6949               call matvec2(auxmat(1,1),Ub2(1,j),
6950      &          AEAb2derx(1,lll,kkk,iii,1,2))
6951               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6952      &          AEAb1derx(1,lll,kkk,iii,2,2))
6953               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6954      &          AEAb2derx(1,lll,kkk,iii,2,2))
6955             enddo
6956           enddo
6957         enddo
6958         ENDIF
6959 C End vectors
6960       else
6961 C Antiparallel orientation of the two CA-CA-CA frames.
6962         if (i.gt.1) then
6963           iti=itortyp(itype(i))
6964         else
6965           iti=ntortyp+1
6966         endif
6967         itk1=itortyp(itype(k+1))
6968         itl=itortyp(itype(l))
6969         itj=itortyp(itype(j))
6970         if (j.lt.nres-1) then
6971           itj1=itortyp(itype(j+1))
6972         else
6973           itj1=ntortyp+1
6974         endif
6975 C A2 kernel(j-1)T A1T
6976         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6977      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6978      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6979 C Following matrices are needed only for 6-th order cumulants
6980         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6981      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6982         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6983      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6984      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6985         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6986      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6987      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6988      &   ADtEAderx(1,1,1,1,1,1))
6989         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6990      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6991      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6992      &   ADtEA1derx(1,1,1,1,1,1))
6993         ENDIF
6994 C End 6-th order cumulants
6995         call transpose2(EUgder(1,1,k),auxmat(1,1))
6996         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6997         call transpose2(EUg(1,1,k),auxmat(1,1))
6998         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6999         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7000         do iii=1,2
7001           do kkk=1,5
7002             do lll=1,3
7003               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7004      &          EAEAderx(1,1,lll,kkk,iii,1))
7005             enddo
7006           enddo
7007         enddo
7008 C A2T kernel(i+1)T A1
7009         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7010      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7011      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7012 C Following matrices are needed only for 6-th order cumulants
7013         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7014      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7015         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7016      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7017      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7018         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7019      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7020      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7021      &   ADtEAderx(1,1,1,1,1,2))
7022         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7023      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7024      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7025      &   ADtEA1derx(1,1,1,1,1,2))
7026         ENDIF
7027 C End 6-th order cumulants
7028         call transpose2(EUgder(1,1,j),auxmat(1,1))
7029         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7030         call transpose2(EUg(1,1,j),auxmat(1,1))
7031         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7032         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7033         do iii=1,2
7034           do kkk=1,5
7035             do lll=1,3
7036               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7037      &          EAEAderx(1,1,lll,kkk,iii,2))
7038             enddo
7039           enddo
7040         enddo
7041 C AEAb1 and AEAb2
7042 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7043 C They are needed only when the fifth- or the sixth-order cumulants are
7044 C indluded.
7045         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7046      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7047         call transpose2(AEA(1,1,1),auxmat(1,1))
7048         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7049         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7050         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7051         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7052         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7053         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7054         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7055         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7056         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7057         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7058         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7059         call transpose2(AEA(1,1,2),auxmat(1,1))
7060         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7061         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7062         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7063         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7064         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7065         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7066         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7067         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7068         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7069         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7070         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7071 C Calculate the Cartesian derivatives of the vectors.
7072         do iii=1,2
7073           do kkk=1,5
7074             do lll=1,3
7075               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7076               call matvec2(auxmat(1,1),b1(1,iti),
7077      &          AEAb1derx(1,lll,kkk,iii,1,1))
7078               call matvec2(auxmat(1,1),Ub2(1,i),
7079      &          AEAb2derx(1,lll,kkk,iii,1,1))
7080               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7081      &          AEAb1derx(1,lll,kkk,iii,2,1))
7082               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7083      &          AEAb2derx(1,lll,kkk,iii,2,1))
7084               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7085               call matvec2(auxmat(1,1),b1(1,itl),
7086      &          AEAb1derx(1,lll,kkk,iii,1,2))
7087               call matvec2(auxmat(1,1),Ub2(1,l),
7088      &          AEAb2derx(1,lll,kkk,iii,1,2))
7089               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7090      &          AEAb1derx(1,lll,kkk,iii,2,2))
7091               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7092      &          AEAb2derx(1,lll,kkk,iii,2,2))
7093             enddo
7094           enddo
7095         enddo
7096         ENDIF
7097 C End vectors
7098       endif
7099       return
7100       end
7101 C---------------------------------------------------------------------------
7102       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7103      &  KK,KKderg,AKA,AKAderg,AKAderx)
7104       implicit none
7105       integer nderg
7106       logical transp
7107       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7108      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7109      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7110       integer iii,kkk,lll
7111       integer jjj,mmm
7112       logical lprn
7113       common /kutas/ lprn
7114       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7115       do iii=1,nderg
7116         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7117      &    AKAderg(1,1,iii))
7118       enddo
7119 cd      if (lprn) write (2,*) 'In kernel'
7120       do kkk=1,5
7121 cd        if (lprn) write (2,*) 'kkk=',kkk
7122         do lll=1,3
7123           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7124      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7125 cd          if (lprn) then
7126 cd            write (2,*) 'lll=',lll
7127 cd            write (2,*) 'iii=1'
7128 cd            do jjj=1,2
7129 cd              write (2,'(3(2f10.5),5x)')
7130 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7131 cd            enddo
7132 cd          endif
7133           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7134      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7135 cd          if (lprn) then
7136 cd            write (2,*) 'lll=',lll
7137 cd            write (2,*) 'iii=2'
7138 cd            do jjj=1,2
7139 cd              write (2,'(3(2f10.5),5x)')
7140 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7141 cd            enddo
7142 cd          endif
7143         enddo
7144       enddo
7145       return
7146       end
7147 C---------------------------------------------------------------------------
7148       double precision function eello4(i,j,k,l,jj,kk)
7149       implicit real*8 (a-h,o-z)
7150       include 'DIMENSIONS'
7151       include 'COMMON.IOUNITS'
7152       include 'COMMON.CHAIN'
7153       include 'COMMON.DERIV'
7154       include 'COMMON.INTERACT'
7155       include 'COMMON.CONTACTS'
7156       include 'COMMON.TORSION'
7157       include 'COMMON.VAR'
7158       include 'COMMON.GEO'
7159       double precision pizda(2,2),ggg1(3),ggg2(3)
7160 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7161 cd        eello4=0.0d0
7162 cd        return
7163 cd      endif
7164 cd      print *,'eello4:',i,j,k,l,jj,kk
7165 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7166 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7167 cold      eij=facont_hb(jj,i)
7168 cold      ekl=facont_hb(kk,k)
7169 cold      ekont=eij*ekl
7170       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7171 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7172       gcorr_loc(k-1)=gcorr_loc(k-1)
7173      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7174       if (l.eq.j+1) then
7175         gcorr_loc(l-1)=gcorr_loc(l-1)
7176      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7177       else
7178         gcorr_loc(j-1)=gcorr_loc(j-1)
7179      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7180       endif
7181       do iii=1,2
7182         do kkk=1,5
7183           do lll=1,3
7184             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7185      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7186 cd            derx(lll,kkk,iii)=0.0d0
7187           enddo
7188         enddo
7189       enddo
7190 cd      gcorr_loc(l-1)=0.0d0
7191 cd      gcorr_loc(j-1)=0.0d0
7192 cd      gcorr_loc(k-1)=0.0d0
7193 cd      eel4=1.0d0
7194 cd      write (iout,*)'Contacts have occurred for peptide groups',
7195 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7196 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7197       if (j.lt.nres-1) then
7198         j1=j+1
7199         j2=j-1
7200       else
7201         j1=j-1
7202         j2=j-2
7203       endif
7204       if (l.lt.nres-1) then
7205         l1=l+1
7206         l2=l-1
7207       else
7208         l1=l-1
7209         l2=l-2
7210       endif
7211       do ll=1,3
7212 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7213 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7214         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7215         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7216 cgrad        ghalf=0.5d0*ggg1(ll)
7217         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7218         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7219         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7220         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7221         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7222         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7223 cgrad        ghalf=0.5d0*ggg2(ll)
7224         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7225         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7226         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7227         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7228         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7229         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7230       enddo
7231 cgrad      do m=i+1,j-1
7232 cgrad        do ll=1,3
7233 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7234 cgrad        enddo
7235 cgrad      enddo
7236 cgrad      do m=k+1,l-1
7237 cgrad        do ll=1,3
7238 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7239 cgrad        enddo
7240 cgrad      enddo
7241 cgrad      do m=i+2,j2
7242 cgrad        do ll=1,3
7243 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7244 cgrad        enddo
7245 cgrad      enddo
7246 cgrad      do m=k+2,l2
7247 cgrad        do ll=1,3
7248 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7249 cgrad        enddo
7250 cgrad      enddo
7251 cd      do iii=1,nres-3
7252 cd        write (2,*) iii,gcorr_loc(iii)
7253 cd      enddo
7254       eello4=ekont*eel4
7255 cd      write (2,*) 'ekont',ekont
7256 cd      write (iout,*) 'eello4',ekont*eel4
7257       return
7258       end
7259 C---------------------------------------------------------------------------
7260       double precision function eello5(i,j,k,l,jj,kk)
7261       implicit real*8 (a-h,o-z)
7262       include 'DIMENSIONS'
7263       include 'COMMON.IOUNITS'
7264       include 'COMMON.CHAIN'
7265       include 'COMMON.DERIV'
7266       include 'COMMON.INTERACT'
7267       include 'COMMON.CONTACTS'
7268       include 'COMMON.TORSION'
7269       include 'COMMON.VAR'
7270       include 'COMMON.GEO'
7271       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7272       double precision ggg1(3),ggg2(3)
7273 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7274 C                                                                              C
7275 C                            Parallel chains                                   C
7276 C                                                                              C
7277 C          o             o                   o             o                   C
7278 C         /l\           / \             \   / \           / \   /              C
7279 C        /   \         /   \             \ /   \         /   \ /               C
7280 C       j| o |l1       | o |              o| o |         | o |o                C
7281 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7282 C      \i/   \         /   \ /             /   \         /   \                 C
7283 C       o    k1             o                                                  C
7284 C         (I)          (II)                (III)          (IV)                 C
7285 C                                                                              C
7286 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7287 C                                                                              C
7288 C                            Antiparallel chains                               C
7289 C                                                                              C
7290 C          o             o                   o             o                   C
7291 C         /j\           / \             \   / \           / \   /              C
7292 C        /   \         /   \             \ /   \         /   \ /               C
7293 C      j1| o |l        | o |              o| o |         | o |o                C
7294 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7295 C      \i/   \         /   \ /             /   \         /   \                 C
7296 C       o     k1            o                                                  C
7297 C         (I)          (II)                (III)          (IV)                 C
7298 C                                                                              C
7299 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7300 C                                                                              C
7301 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7302 C                                                                              C
7303 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7304 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7305 cd        eello5=0.0d0
7306 cd        return
7307 cd      endif
7308 cd      write (iout,*)
7309 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7310 cd     &   ' and',k,l
7311       itk=itortyp(itype(k))
7312       itl=itortyp(itype(l))
7313       itj=itortyp(itype(j))
7314       eello5_1=0.0d0
7315       eello5_2=0.0d0
7316       eello5_3=0.0d0
7317       eello5_4=0.0d0
7318 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7319 cd     &   eel5_3_num,eel5_4_num)
7320       do iii=1,2
7321         do kkk=1,5
7322           do lll=1,3
7323             derx(lll,kkk,iii)=0.0d0
7324           enddo
7325         enddo
7326       enddo
7327 cd      eij=facont_hb(jj,i)
7328 cd      ekl=facont_hb(kk,k)
7329 cd      ekont=eij*ekl
7330 cd      write (iout,*)'Contacts have occurred for peptide groups',
7331 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7332 cd      goto 1111
7333 C Contribution from the graph I.
7334 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7335 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7336       call transpose2(EUg(1,1,k),auxmat(1,1))
7337       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7338       vv(1)=pizda(1,1)-pizda(2,2)
7339       vv(2)=pizda(1,2)+pizda(2,1)
7340       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7341      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7342 C Explicit gradient in virtual-dihedral angles.
7343       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7344      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7345      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7346       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7347       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7348       vv(1)=pizda(1,1)-pizda(2,2)
7349       vv(2)=pizda(1,2)+pizda(2,1)
7350       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7351      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7352      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7353       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7354       vv(1)=pizda(1,1)-pizda(2,2)
7355       vv(2)=pizda(1,2)+pizda(2,1)
7356       if (l.eq.j+1) then
7357         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7358      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7359      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7360       else
7361         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7362      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7363      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7364       endif
7365 C Cartesian gradient
7366       do iii=1,2
7367         do kkk=1,5
7368           do lll=1,3
7369             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7370      &        pizda(1,1))
7371             vv(1)=pizda(1,1)-pizda(2,2)
7372             vv(2)=pizda(1,2)+pizda(2,1)
7373             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7374      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7375      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7376           enddo
7377         enddo
7378       enddo
7379 c      goto 1112
7380 c1111  continue
7381 C Contribution from graph II
7382       call transpose2(EE(1,1,itk),auxmat(1,1))
7383       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7384       vv(1)=pizda(1,1)+pizda(2,2)
7385       vv(2)=pizda(2,1)-pizda(1,2)
7386       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7387      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7388 C Explicit gradient in virtual-dihedral angles.
7389       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7390      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7391       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7392       vv(1)=pizda(1,1)+pizda(2,2)
7393       vv(2)=pizda(2,1)-pizda(1,2)
7394       if (l.eq.j+1) then
7395         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7396      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7397      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7398       else
7399         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7400      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7401      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7402       endif
7403 C Cartesian gradient
7404       do iii=1,2
7405         do kkk=1,5
7406           do lll=1,3
7407             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7408      &        pizda(1,1))
7409             vv(1)=pizda(1,1)+pizda(2,2)
7410             vv(2)=pizda(2,1)-pizda(1,2)
7411             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7412      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7413      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7414           enddo
7415         enddo
7416       enddo
7417 cd      goto 1112
7418 cd1111  continue
7419       if (l.eq.j+1) then
7420 cd        goto 1110
7421 C Parallel orientation
7422 C Contribution from graph III
7423         call transpose2(EUg(1,1,l),auxmat(1,1))
7424         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7425         vv(1)=pizda(1,1)-pizda(2,2)
7426         vv(2)=pizda(1,2)+pizda(2,1)
7427         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7428      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7429 C Explicit gradient in virtual-dihedral angles.
7430         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7431      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7432      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7433         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7434         vv(1)=pizda(1,1)-pizda(2,2)
7435         vv(2)=pizda(1,2)+pizda(2,1)
7436         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7437      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7438      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7439         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7440         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7441         vv(1)=pizda(1,1)-pizda(2,2)
7442         vv(2)=pizda(1,2)+pizda(2,1)
7443         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7444      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7445      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7446 C Cartesian gradient
7447         do iii=1,2
7448           do kkk=1,5
7449             do lll=1,3
7450               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7451      &          pizda(1,1))
7452               vv(1)=pizda(1,1)-pizda(2,2)
7453               vv(2)=pizda(1,2)+pizda(2,1)
7454               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7455      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7456      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7457             enddo
7458           enddo
7459         enddo
7460 cd        goto 1112
7461 C Contribution from graph IV
7462 cd1110    continue
7463         call transpose2(EE(1,1,itl),auxmat(1,1))
7464         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7465         vv(1)=pizda(1,1)+pizda(2,2)
7466         vv(2)=pizda(2,1)-pizda(1,2)
7467         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7468      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7469 C Explicit gradient in virtual-dihedral angles.
7470         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7471      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7472         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7473         vv(1)=pizda(1,1)+pizda(2,2)
7474         vv(2)=pizda(2,1)-pizda(1,2)
7475         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7476      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7477      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7478 C Cartesian gradient
7479         do iii=1,2
7480           do kkk=1,5
7481             do lll=1,3
7482               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7483      &          pizda(1,1))
7484               vv(1)=pizda(1,1)+pizda(2,2)
7485               vv(2)=pizda(2,1)-pizda(1,2)
7486               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7487      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7488      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7489             enddo
7490           enddo
7491         enddo
7492       else
7493 C Antiparallel orientation
7494 C Contribution from graph III
7495 c        goto 1110
7496         call transpose2(EUg(1,1,j),auxmat(1,1))
7497         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7498         vv(1)=pizda(1,1)-pizda(2,2)
7499         vv(2)=pizda(1,2)+pizda(2,1)
7500         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7501      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7502 C Explicit gradient in virtual-dihedral angles.
7503         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7504      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7505      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7506         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7507         vv(1)=pizda(1,1)-pizda(2,2)
7508         vv(2)=pizda(1,2)+pizda(2,1)
7509         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7510      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7511      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7512         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7513         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7514         vv(1)=pizda(1,1)-pizda(2,2)
7515         vv(2)=pizda(1,2)+pizda(2,1)
7516         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7517      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7518      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7519 C Cartesian gradient
7520         do iii=1,2
7521           do kkk=1,5
7522             do lll=1,3
7523               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7524      &          pizda(1,1))
7525               vv(1)=pizda(1,1)-pizda(2,2)
7526               vv(2)=pizda(1,2)+pizda(2,1)
7527               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7528      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7529      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7530             enddo
7531           enddo
7532         enddo
7533 cd        goto 1112
7534 C Contribution from graph IV
7535 1110    continue
7536         call transpose2(EE(1,1,itj),auxmat(1,1))
7537         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7538         vv(1)=pizda(1,1)+pizda(2,2)
7539         vv(2)=pizda(2,1)-pizda(1,2)
7540         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7541      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7542 C Explicit gradient in virtual-dihedral angles.
7543         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7544      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7545         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7546         vv(1)=pizda(1,1)+pizda(2,2)
7547         vv(2)=pizda(2,1)-pizda(1,2)
7548         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7549      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7550      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7551 C Cartesian gradient
7552         do iii=1,2
7553           do kkk=1,5
7554             do lll=1,3
7555               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7556      &          pizda(1,1))
7557               vv(1)=pizda(1,1)+pizda(2,2)
7558               vv(2)=pizda(2,1)-pizda(1,2)
7559               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7560      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7561      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7562             enddo
7563           enddo
7564         enddo
7565       endif
7566 1112  continue
7567       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7568 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7569 cd        write (2,*) 'ijkl',i,j,k,l
7570 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7571 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7572 cd      endif
7573 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7574 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7575 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7576 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7577       if (j.lt.nres-1) then
7578         j1=j+1
7579         j2=j-1
7580       else
7581         j1=j-1
7582         j2=j-2
7583       endif
7584       if (l.lt.nres-1) then
7585         l1=l+1
7586         l2=l-1
7587       else
7588         l1=l-1
7589         l2=l-2
7590       endif
7591 cd      eij=1.0d0
7592 cd      ekl=1.0d0
7593 cd      ekont=1.0d0
7594 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7595 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7596 C        summed up outside the subrouine as for the other subroutines
7597 C        handling long-range interactions. The old code is commented out
7598 C        with "cgrad" to keep track of changes.
7599       do ll=1,3
7600 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7601 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7602         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7603         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7604 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7605 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7606 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7607 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7608 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7609 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7610 c     &   gradcorr5ij,
7611 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7612 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7613 cgrad        ghalf=0.5d0*ggg1(ll)
7614 cd        ghalf=0.0d0
7615         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7616         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7617         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7618         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7619         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7620         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7621 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7622 cgrad        ghalf=0.5d0*ggg2(ll)
7623 cd        ghalf=0.0d0
7624         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7625         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7626         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7627         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7628         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7629         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7630       enddo
7631 cd      goto 1112
7632 cgrad      do m=i+1,j-1
7633 cgrad        do ll=1,3
7634 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7635 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7636 cgrad        enddo
7637 cgrad      enddo
7638 cgrad      do m=k+1,l-1
7639 cgrad        do ll=1,3
7640 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7641 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7642 cgrad        enddo
7643 cgrad      enddo
7644 c1112  continue
7645 cgrad      do m=i+2,j2
7646 cgrad        do ll=1,3
7647 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7648 cgrad        enddo
7649 cgrad      enddo
7650 cgrad      do m=k+2,l2
7651 cgrad        do ll=1,3
7652 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7653 cgrad        enddo
7654 cgrad      enddo
7655 cd      do iii=1,nres-3
7656 cd        write (2,*) iii,g_corr5_loc(iii)
7657 cd      enddo
7658       eello5=ekont*eel5
7659 cd      write (2,*) 'ekont',ekont
7660 cd      write (iout,*) 'eello5',ekont*eel5
7661       return
7662       end
7663 c--------------------------------------------------------------------------
7664       double precision function eello6(i,j,k,l,jj,kk)
7665       implicit real*8 (a-h,o-z)
7666       include 'DIMENSIONS'
7667       include 'COMMON.IOUNITS'
7668       include 'COMMON.CHAIN'
7669       include 'COMMON.DERIV'
7670       include 'COMMON.INTERACT'
7671       include 'COMMON.CONTACTS'
7672       include 'COMMON.TORSION'
7673       include 'COMMON.VAR'
7674       include 'COMMON.GEO'
7675       include 'COMMON.FFIELD'
7676       double precision ggg1(3),ggg2(3)
7677 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7678 cd        eello6=0.0d0
7679 cd        return
7680 cd      endif
7681 cd      write (iout,*)
7682 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7683 cd     &   ' and',k,l
7684       eello6_1=0.0d0
7685       eello6_2=0.0d0
7686       eello6_3=0.0d0
7687       eello6_4=0.0d0
7688       eello6_5=0.0d0
7689       eello6_6=0.0d0
7690 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7691 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7692       do iii=1,2
7693         do kkk=1,5
7694           do lll=1,3
7695             derx(lll,kkk,iii)=0.0d0
7696           enddo
7697         enddo
7698       enddo
7699 cd      eij=facont_hb(jj,i)
7700 cd      ekl=facont_hb(kk,k)
7701 cd      ekont=eij*ekl
7702 cd      eij=1.0d0
7703 cd      ekl=1.0d0
7704 cd      ekont=1.0d0
7705       if (l.eq.j+1) then
7706         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7707         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7708         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7709         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7710         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7711         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7712       else
7713         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7714         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7715         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7716         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7717         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7718           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7719         else
7720           eello6_5=0.0d0
7721         endif
7722         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7723       endif
7724 C If turn contributions are considered, they will be handled separately.
7725       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7726 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7727 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7728 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7729 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7730 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7731 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7732 cd      goto 1112
7733       if (j.lt.nres-1) then
7734         j1=j+1
7735         j2=j-1
7736       else
7737         j1=j-1
7738         j2=j-2
7739       endif
7740       if (l.lt.nres-1) then
7741         l1=l+1
7742         l2=l-1
7743       else
7744         l1=l-1
7745         l2=l-2
7746       endif
7747       do ll=1,3
7748 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7749 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7750 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7751 cgrad        ghalf=0.5d0*ggg1(ll)
7752 cd        ghalf=0.0d0
7753         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7754         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7755         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7756         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7757         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7758         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7759         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7760         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7761 cgrad        ghalf=0.5d0*ggg2(ll)
7762 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7763 cd        ghalf=0.0d0
7764         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7765         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7766         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7767         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7768         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7769         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7770       enddo
7771 cd      goto 1112
7772 cgrad      do m=i+1,j-1
7773 cgrad        do ll=1,3
7774 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7775 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7776 cgrad        enddo
7777 cgrad      enddo
7778 cgrad      do m=k+1,l-1
7779 cgrad        do ll=1,3
7780 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7781 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7782 cgrad        enddo
7783 cgrad      enddo
7784 cgrad1112  continue
7785 cgrad      do m=i+2,j2
7786 cgrad        do ll=1,3
7787 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7788 cgrad        enddo
7789 cgrad      enddo
7790 cgrad      do m=k+2,l2
7791 cgrad        do ll=1,3
7792 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7793 cgrad        enddo
7794 cgrad      enddo
7795 cd      do iii=1,nres-3
7796 cd        write (2,*) iii,g_corr6_loc(iii)
7797 cd      enddo
7798       eello6=ekont*eel6
7799 cd      write (2,*) 'ekont',ekont
7800 cd      write (iout,*) 'eello6',ekont*eel6
7801       return
7802       end
7803 c--------------------------------------------------------------------------
7804       double precision function eello6_graph1(i,j,k,l,imat,swap)
7805       implicit real*8 (a-h,o-z)
7806       include 'DIMENSIONS'
7807       include 'COMMON.IOUNITS'
7808       include 'COMMON.CHAIN'
7809       include 'COMMON.DERIV'
7810       include 'COMMON.INTERACT'
7811       include 'COMMON.CONTACTS'
7812       include 'COMMON.TORSION'
7813       include 'COMMON.VAR'
7814       include 'COMMON.GEO'
7815       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7816       logical swap
7817       logical lprn
7818       common /kutas/ lprn
7819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7820 C                                                                              C
7821 C      Parallel       Antiparallel                                             C
7822 C                                                                              C
7823 C          o             o                                                     C
7824 C         /l\           /j\                                                    C
7825 C        /   \         /   \                                                   C
7826 C       /| o |         | o |\                                                  C
7827 C     \ j|/k\|  /   \  |/k\|l /                                                C
7828 C      \ /   \ /     \ /   \ /                                                 C
7829 C       o     o       o     o                                                  C
7830 C       i             i                                                        C
7831 C                                                                              C
7832 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7833       itk=itortyp(itype(k))
7834       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7835       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7836       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7837       call transpose2(EUgC(1,1,k),auxmat(1,1))
7838       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7839       vv1(1)=pizda1(1,1)-pizda1(2,2)
7840       vv1(2)=pizda1(1,2)+pizda1(2,1)
7841       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7842       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7843       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7844       s5=scalar2(vv(1),Dtobr2(1,i))
7845 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7846       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7847       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7848      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7849      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7850      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7851      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7852      & +scalar2(vv(1),Dtobr2der(1,i)))
7853       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7854       vv1(1)=pizda1(1,1)-pizda1(2,2)
7855       vv1(2)=pizda1(1,2)+pizda1(2,1)
7856       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7857       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7858       if (l.eq.j+1) then
7859         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7860      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7861      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7862      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7863      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7864       else
7865         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7866      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7867      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7868      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7869      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7870       endif
7871       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7872       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7873       vv1(1)=pizda1(1,1)-pizda1(2,2)
7874       vv1(2)=pizda1(1,2)+pizda1(2,1)
7875       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7876      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7877      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7878      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7879       do iii=1,2
7880         if (swap) then
7881           ind=3-iii
7882         else
7883           ind=iii
7884         endif
7885         do kkk=1,5
7886           do lll=1,3
7887             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7888             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7889             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7890             call transpose2(EUgC(1,1,k),auxmat(1,1))
7891             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7892      &        pizda1(1,1))
7893             vv1(1)=pizda1(1,1)-pizda1(2,2)
7894             vv1(2)=pizda1(1,2)+pizda1(2,1)
7895             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7896             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7897      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7898             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7899      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7900             s5=scalar2(vv(1),Dtobr2(1,i))
7901             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7902           enddo
7903         enddo
7904       enddo
7905       return
7906       end
7907 c----------------------------------------------------------------------------
7908       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7909       implicit real*8 (a-h,o-z)
7910       include 'DIMENSIONS'
7911       include 'COMMON.IOUNITS'
7912       include 'COMMON.CHAIN'
7913       include 'COMMON.DERIV'
7914       include 'COMMON.INTERACT'
7915       include 'COMMON.CONTACTS'
7916       include 'COMMON.TORSION'
7917       include 'COMMON.VAR'
7918       include 'COMMON.GEO'
7919       logical swap
7920       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7921      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7922       logical lprn
7923       common /kutas/ lprn
7924 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7925 C                                                                              C
7926 C      Parallel       Antiparallel                                             C
7927 C                                                                              C
7928 C          o             o                                                     C
7929 C     \   /l\           /j\   /                                                C
7930 C      \ /   \         /   \ /                                                 C
7931 C       o| o |         | o |o                                                  C
7932 C     \ j|/k\|      \  |/k\|l                                                  C
7933 C      \ /   \       \ /   \                                                   C
7934 C       o             o                                                        C
7935 C       i             i                                                        C
7936 C                                                                              C
7937 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7938 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7939 C AL 7/4/01 s1 would occur in the sixth-order moment,
7940 C           but not in a cluster cumulant
7941 #ifdef MOMENT
7942       s1=dip(1,jj,i)*dip(1,kk,k)
7943 #endif
7944       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7945       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7946       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7947       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7948       call transpose2(EUg(1,1,k),auxmat(1,1))
7949       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7950       vv(1)=pizda(1,1)-pizda(2,2)
7951       vv(2)=pizda(1,2)+pizda(2,1)
7952       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7953 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7954 #ifdef MOMENT
7955       eello6_graph2=-(s1+s2+s3+s4)
7956 #else
7957       eello6_graph2=-(s2+s3+s4)
7958 #endif
7959 c      eello6_graph2=-s3
7960 C Derivatives in gamma(i-1)
7961       if (i.gt.1) then
7962 #ifdef MOMENT
7963         s1=dipderg(1,jj,i)*dip(1,kk,k)
7964 #endif
7965         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7966         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7967         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7968         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7969 #ifdef MOMENT
7970         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7971 #else
7972         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7973 #endif
7974 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7975       endif
7976 C Derivatives in gamma(k-1)
7977 #ifdef MOMENT
7978       s1=dip(1,jj,i)*dipderg(1,kk,k)
7979 #endif
7980       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7981       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7982       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7983       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7984       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7985       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7986       vv(1)=pizda(1,1)-pizda(2,2)
7987       vv(2)=pizda(1,2)+pizda(2,1)
7988       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7989 #ifdef MOMENT
7990       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7991 #else
7992       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7993 #endif
7994 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7995 C Derivatives in gamma(j-1) or gamma(l-1)
7996       if (j.gt.1) then
7997 #ifdef MOMENT
7998         s1=dipderg(3,jj,i)*dip(1,kk,k)
7999 #endif
8000         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8001         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8002         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8003         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8004         vv(1)=pizda(1,1)-pizda(2,2)
8005         vv(2)=pizda(1,2)+pizda(2,1)
8006         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8007 #ifdef MOMENT
8008         if (swap) then
8009           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8010         else
8011           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8012         endif
8013 #endif
8014         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8015 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8016       endif
8017 C Derivatives in gamma(l-1) or gamma(j-1)
8018       if (l.gt.1) then
8019 #ifdef MOMENT
8020         s1=dip(1,jj,i)*dipderg(3,kk,k)
8021 #endif
8022         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8023         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8024         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8025         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8026         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8027         vv(1)=pizda(1,1)-pizda(2,2)
8028         vv(2)=pizda(1,2)+pizda(2,1)
8029         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8030 #ifdef MOMENT
8031         if (swap) then
8032           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8033         else
8034           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8035         endif
8036 #endif
8037         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8038 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8039       endif
8040 C Cartesian derivatives.
8041       if (lprn) then
8042         write (2,*) 'In eello6_graph2'
8043         do iii=1,2
8044           write (2,*) 'iii=',iii
8045           do kkk=1,5
8046             write (2,*) 'kkk=',kkk
8047             do jjj=1,2
8048               write (2,'(3(2f10.5),5x)')
8049      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8050             enddo
8051           enddo
8052         enddo
8053       endif
8054       do iii=1,2
8055         do kkk=1,5
8056           do lll=1,3
8057 #ifdef MOMENT
8058             if (iii.eq.1) then
8059               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8060             else
8061               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8062             endif
8063 #endif
8064             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8065      &        auxvec(1))
8066             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8067             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8068      &        auxvec(1))
8069             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8070             call transpose2(EUg(1,1,k),auxmat(1,1))
8071             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8072      &        pizda(1,1))
8073             vv(1)=pizda(1,1)-pizda(2,2)
8074             vv(2)=pizda(1,2)+pizda(2,1)
8075             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8076 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8077 #ifdef MOMENT
8078             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8079 #else
8080             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8081 #endif
8082             if (swap) then
8083               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8084             else
8085               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8086             endif
8087           enddo
8088         enddo
8089       enddo
8090       return
8091       end
8092 c----------------------------------------------------------------------------
8093       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8094       implicit real*8 (a-h,o-z)
8095       include 'DIMENSIONS'
8096       include 'COMMON.IOUNITS'
8097       include 'COMMON.CHAIN'
8098       include 'COMMON.DERIV'
8099       include 'COMMON.INTERACT'
8100       include 'COMMON.CONTACTS'
8101       include 'COMMON.TORSION'
8102       include 'COMMON.VAR'
8103       include 'COMMON.GEO'
8104       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8105       logical swap
8106 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8107 C                                                                              C
8108 C      Parallel       Antiparallel                                             C
8109 C                                                                              C
8110 C          o             o                                                     C
8111 C         /l\   /   \   /j\                                                    C
8112 C        /   \ /     \ /   \                                                   C
8113 C       /| o |o       o| o |\                                                  C
8114 C       j|/k\|  /      |/k\|l /                                                C
8115 C        /   \ /       /   \ /                                                 C
8116 C       /     o       /     o                                                  C
8117 C       i             i                                                        C
8118 C                                                                              C
8119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8120 C
8121 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8122 C           energy moment and not to the cluster cumulant.
8123       iti=itortyp(itype(i))
8124       if (j.lt.nres-1) then
8125         itj1=itortyp(itype(j+1))
8126       else
8127         itj1=ntortyp+1
8128       endif
8129       itk=itortyp(itype(k))
8130       itk1=itortyp(itype(k+1))
8131       if (l.lt.nres-1) then
8132         itl1=itortyp(itype(l+1))
8133       else
8134         itl1=ntortyp+1
8135       endif
8136 #ifdef MOMENT
8137       s1=dip(4,jj,i)*dip(4,kk,k)
8138 #endif
8139       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8140       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8141       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8142       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8143       call transpose2(EE(1,1,itk),auxmat(1,1))
8144       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8145       vv(1)=pizda(1,1)+pizda(2,2)
8146       vv(2)=pizda(2,1)-pizda(1,2)
8147       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8148 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8149 cd     & "sum",-(s2+s3+s4)
8150 #ifdef MOMENT
8151       eello6_graph3=-(s1+s2+s3+s4)
8152 #else
8153       eello6_graph3=-(s2+s3+s4)
8154 #endif
8155 c      eello6_graph3=-s4
8156 C Derivatives in gamma(k-1)
8157       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8158       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8159       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8160       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8161 C Derivatives in gamma(l-1)
8162       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8163       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8164       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8165       vv(1)=pizda(1,1)+pizda(2,2)
8166       vv(2)=pizda(2,1)-pizda(1,2)
8167       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8168       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8169 C Cartesian derivatives.
8170       do iii=1,2
8171         do kkk=1,5
8172           do lll=1,3
8173 #ifdef MOMENT
8174             if (iii.eq.1) then
8175               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8176             else
8177               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8178             endif
8179 #endif
8180             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8181      &        auxvec(1))
8182             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8183             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8184      &        auxvec(1))
8185             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8186             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8187      &        pizda(1,1))
8188             vv(1)=pizda(1,1)+pizda(2,2)
8189             vv(2)=pizda(2,1)-pizda(1,2)
8190             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8191 #ifdef MOMENT
8192             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8193 #else
8194             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8195 #endif
8196             if (swap) then
8197               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8198             else
8199               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8200             endif
8201 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8202           enddo
8203         enddo
8204       enddo
8205       return
8206       end
8207 c----------------------------------------------------------------------------
8208       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8209       implicit real*8 (a-h,o-z)
8210       include 'DIMENSIONS'
8211       include 'COMMON.IOUNITS'
8212       include 'COMMON.CHAIN'
8213       include 'COMMON.DERIV'
8214       include 'COMMON.INTERACT'
8215       include 'COMMON.CONTACTS'
8216       include 'COMMON.TORSION'
8217       include 'COMMON.VAR'
8218       include 'COMMON.GEO'
8219       include 'COMMON.FFIELD'
8220       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8221      & auxvec1(2),auxmat1(2,2)
8222       logical swap
8223 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8224 C                                                                              C
8225 C      Parallel       Antiparallel                                             C
8226 C                                                                              C
8227 C          o             o                                                     C
8228 C         /l\   /   \   /j\                                                    C
8229 C        /   \ /     \ /   \                                                   C
8230 C       /| o |o       o| o |\                                                  C
8231 C     \ j|/k\|      \  |/k\|l                                                  C
8232 C      \ /   \       \ /   \                                                   C
8233 C       o     \       o     \                                                  C
8234 C       i             i                                                        C
8235 C                                                                              C
8236 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8237 C
8238 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8239 C           energy moment and not to the cluster cumulant.
8240 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8241       iti=itortyp(itype(i))
8242       itj=itortyp(itype(j))
8243       if (j.lt.nres-1) then
8244         itj1=itortyp(itype(j+1))
8245       else
8246         itj1=ntortyp+1
8247       endif
8248       itk=itortyp(itype(k))
8249       if (k.lt.nres-1) then
8250         itk1=itortyp(itype(k+1))
8251       else
8252         itk1=ntortyp+1
8253       endif
8254       itl=itortyp(itype(l))
8255       if (l.lt.nres-1) then
8256         itl1=itortyp(itype(l+1))
8257       else
8258         itl1=ntortyp+1
8259       endif
8260 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8261 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8262 cd     & ' itl',itl,' itl1',itl1
8263 #ifdef MOMENT
8264       if (imat.eq.1) then
8265         s1=dip(3,jj,i)*dip(3,kk,k)
8266       else
8267         s1=dip(2,jj,j)*dip(2,kk,l)
8268       endif
8269 #endif
8270       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8271       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8272       if (j.eq.l+1) then
8273         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8274         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8275       else
8276         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8277         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8278       endif
8279       call transpose2(EUg(1,1,k),auxmat(1,1))
8280       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8281       vv(1)=pizda(1,1)-pizda(2,2)
8282       vv(2)=pizda(2,1)+pizda(1,2)
8283       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8284 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8285 #ifdef MOMENT
8286       eello6_graph4=-(s1+s2+s3+s4)
8287 #else
8288       eello6_graph4=-(s2+s3+s4)
8289 #endif
8290 C Derivatives in gamma(i-1)
8291       if (i.gt.1) then
8292 #ifdef MOMENT
8293         if (imat.eq.1) then
8294           s1=dipderg(2,jj,i)*dip(3,kk,k)
8295         else
8296           s1=dipderg(4,jj,j)*dip(2,kk,l)
8297         endif
8298 #endif
8299         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8300         if (j.eq.l+1) then
8301           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8302           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8303         else
8304           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8305           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8306         endif
8307         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8308         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8309 cd          write (2,*) 'turn6 derivatives'
8310 #ifdef MOMENT
8311           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8312 #else
8313           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8314 #endif
8315         else
8316 #ifdef MOMENT
8317           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8318 #else
8319           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8320 #endif
8321         endif
8322       endif
8323 C Derivatives in gamma(k-1)
8324 #ifdef MOMENT
8325       if (imat.eq.1) then
8326         s1=dip(3,jj,i)*dipderg(2,kk,k)
8327       else
8328         s1=dip(2,jj,j)*dipderg(4,kk,l)
8329       endif
8330 #endif
8331       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8332       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8333       if (j.eq.l+1) then
8334         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8335         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8336       else
8337         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8338         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8339       endif
8340       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8341       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8342       vv(1)=pizda(1,1)-pizda(2,2)
8343       vv(2)=pizda(2,1)+pizda(1,2)
8344       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8345       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8346 #ifdef MOMENT
8347         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8348 #else
8349         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8350 #endif
8351       else
8352 #ifdef MOMENT
8353         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8354 #else
8355         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8356 #endif
8357       endif
8358 C Derivatives in gamma(j-1) or gamma(l-1)
8359       if (l.eq.j+1 .and. l.gt.1) then
8360         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8361         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8362         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8363         vv(1)=pizda(1,1)-pizda(2,2)
8364         vv(2)=pizda(2,1)+pizda(1,2)
8365         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8366         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8367       else if (j.gt.1) then
8368         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8369         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8370         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8371         vv(1)=pizda(1,1)-pizda(2,2)
8372         vv(2)=pizda(2,1)+pizda(1,2)
8373         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8374         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8375           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8376         else
8377           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8378         endif
8379       endif
8380 C Cartesian derivatives.
8381       do iii=1,2
8382         do kkk=1,5
8383           do lll=1,3
8384 #ifdef MOMENT
8385             if (iii.eq.1) then
8386               if (imat.eq.1) then
8387                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8388               else
8389                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8390               endif
8391             else
8392               if (imat.eq.1) then
8393                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8394               else
8395                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8396               endif
8397             endif
8398 #endif
8399             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8400      &        auxvec(1))
8401             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8402             if (j.eq.l+1) then
8403               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8404      &          b1(1,itj1),auxvec(1))
8405               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8406             else
8407               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8408      &          b1(1,itl1),auxvec(1))
8409               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8410             endif
8411             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8412      &        pizda(1,1))
8413             vv(1)=pizda(1,1)-pizda(2,2)
8414             vv(2)=pizda(2,1)+pizda(1,2)
8415             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8416             if (swap) then
8417               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8418 #ifdef MOMENT
8419                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8420      &             -(s1+s2+s4)
8421 #else
8422                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8423      &             -(s2+s4)
8424 #endif
8425                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8426               else
8427 #ifdef MOMENT
8428                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8429 #else
8430                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8431 #endif
8432                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8433               endif
8434             else
8435 #ifdef MOMENT
8436               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8437 #else
8438               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8439 #endif
8440               if (l.eq.j+1) then
8441                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8442               else
8443                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8444               endif
8445             endif
8446           enddo
8447         enddo
8448       enddo
8449       return
8450       end
8451 c----------------------------------------------------------------------------
8452       double precision function eello_turn6(i,jj,kk)
8453       implicit real*8 (a-h,o-z)
8454       include 'DIMENSIONS'
8455       include 'COMMON.IOUNITS'
8456       include 'COMMON.CHAIN'
8457       include 'COMMON.DERIV'
8458       include 'COMMON.INTERACT'
8459       include 'COMMON.CONTACTS'
8460       include 'COMMON.TORSION'
8461       include 'COMMON.VAR'
8462       include 'COMMON.GEO'
8463       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8464      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8465      &  ggg1(3),ggg2(3)
8466       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8467      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8468 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8469 C           the respective energy moment and not to the cluster cumulant.
8470       s1=0.0d0
8471       s8=0.0d0
8472       s13=0.0d0
8473 c
8474       eello_turn6=0.0d0
8475       j=i+4
8476       k=i+1
8477       l=i+3
8478       iti=itortyp(itype(i))
8479       itk=itortyp(itype(k))
8480       itk1=itortyp(itype(k+1))
8481       itl=itortyp(itype(l))
8482       itj=itortyp(itype(j))
8483 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8484 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8485 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8486 cd        eello6=0.0d0
8487 cd        return
8488 cd      endif
8489 cd      write (iout,*)
8490 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8491 cd     &   ' and',k,l
8492 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8493       do iii=1,2
8494         do kkk=1,5
8495           do lll=1,3
8496             derx_turn(lll,kkk,iii)=0.0d0
8497           enddo
8498         enddo
8499       enddo
8500 cd      eij=1.0d0
8501 cd      ekl=1.0d0
8502 cd      ekont=1.0d0
8503       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8504 cd      eello6_5=0.0d0
8505 cd      write (2,*) 'eello6_5',eello6_5
8506 #ifdef MOMENT
8507       call transpose2(AEA(1,1,1),auxmat(1,1))
8508       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8509       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8510       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8511 #endif
8512       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8513       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8514       s2 = scalar2(b1(1,itk),vtemp1(1))
8515 #ifdef MOMENT
8516       call transpose2(AEA(1,1,2),atemp(1,1))
8517       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8518       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8519       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8520 #endif
8521       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8522       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8523       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8524 #ifdef MOMENT
8525       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8526       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8527       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8528       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8529       ss13 = scalar2(b1(1,itk),vtemp4(1))
8530       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8531 #endif
8532 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8533 c      s1=0.0d0
8534 c      s2=0.0d0
8535 c      s8=0.0d0
8536 c      s12=0.0d0
8537 c      s13=0.0d0
8538       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8539 C Derivatives in gamma(i+2)
8540       s1d =0.0d0
8541       s8d =0.0d0
8542 #ifdef MOMENT
8543       call transpose2(AEA(1,1,1),auxmatd(1,1))
8544       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8545       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8546       call transpose2(AEAderg(1,1,2),atempd(1,1))
8547       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8548       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8549 #endif
8550       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8551       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8552       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8553 c      s1d=0.0d0
8554 c      s2d=0.0d0
8555 c      s8d=0.0d0
8556 c      s12d=0.0d0
8557 c      s13d=0.0d0
8558       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8559 C Derivatives in gamma(i+3)
8560 #ifdef MOMENT
8561       call transpose2(AEA(1,1,1),auxmatd(1,1))
8562       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8563       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8564       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8565 #endif
8566       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8567       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8568       s2d = scalar2(b1(1,itk),vtemp1d(1))
8569 #ifdef MOMENT
8570       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8571       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8572 #endif
8573       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8574 #ifdef MOMENT
8575       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8576       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8577       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8578 #endif
8579 c      s1d=0.0d0
8580 c      s2d=0.0d0
8581 c      s8d=0.0d0
8582 c      s12d=0.0d0
8583 c      s13d=0.0d0
8584 #ifdef MOMENT
8585       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8586      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8587 #else
8588       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8589      &               -0.5d0*ekont*(s2d+s12d)
8590 #endif
8591 C Derivatives in gamma(i+4)
8592       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8593       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8594       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8595 #ifdef MOMENT
8596       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8597       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8598       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8599 #endif
8600 c      s1d=0.0d0
8601 c      s2d=0.0d0
8602 c      s8d=0.0d0
8603 C      s12d=0.0d0
8604 c      s13d=0.0d0
8605 #ifdef MOMENT
8606       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8607 #else
8608       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8609 #endif
8610 C Derivatives in gamma(i+5)
8611 #ifdef MOMENT
8612       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8613       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8614       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8615 #endif
8616       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8617       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8618       s2d = scalar2(b1(1,itk),vtemp1d(1))
8619 #ifdef MOMENT
8620       call transpose2(AEA(1,1,2),atempd(1,1))
8621       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8622       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8623 #endif
8624       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8625       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8626 #ifdef MOMENT
8627       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8628       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8629       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8630 #endif
8631 c      s1d=0.0d0
8632 c      s2d=0.0d0
8633 c      s8d=0.0d0
8634 c      s12d=0.0d0
8635 c      s13d=0.0d0
8636 #ifdef MOMENT
8637       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8638      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8639 #else
8640       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8641      &               -0.5d0*ekont*(s2d+s12d)
8642 #endif
8643 C Cartesian derivatives
8644       do iii=1,2
8645         do kkk=1,5
8646           do lll=1,3
8647 #ifdef MOMENT
8648             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8649             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8650             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8651 #endif
8652             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8653             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8654      &          vtemp1d(1))
8655             s2d = scalar2(b1(1,itk),vtemp1d(1))
8656 #ifdef MOMENT
8657             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8658             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8659             s8d = -(atempd(1,1)+atempd(2,2))*
8660      &           scalar2(cc(1,1,itl),vtemp2(1))
8661 #endif
8662             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8663      &           auxmatd(1,1))
8664             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8665             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8666 c      s1d=0.0d0
8667 c      s2d=0.0d0
8668 c      s8d=0.0d0
8669 c      s12d=0.0d0
8670 c      s13d=0.0d0
8671 #ifdef MOMENT
8672             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8673      &        - 0.5d0*(s1d+s2d)
8674 #else
8675             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8676      &        - 0.5d0*s2d
8677 #endif
8678 #ifdef MOMENT
8679             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8680      &        - 0.5d0*(s8d+s12d)
8681 #else
8682             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8683      &        - 0.5d0*s12d
8684 #endif
8685           enddo
8686         enddo
8687       enddo
8688 #ifdef MOMENT
8689       do kkk=1,5
8690         do lll=1,3
8691           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8692      &      achuj_tempd(1,1))
8693           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8694           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8695           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8696           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8697           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8698      &      vtemp4d(1))
8699           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8700           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8701           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8702         enddo
8703       enddo
8704 #endif
8705 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8706 cd     &  16*eel_turn6_num
8707 cd      goto 1112
8708       if (j.lt.nres-1) then
8709         j1=j+1
8710         j2=j-1
8711       else
8712         j1=j-1
8713         j2=j-2
8714       endif
8715       if (l.lt.nres-1) then
8716         l1=l+1
8717         l2=l-1
8718       else
8719         l1=l-1
8720         l2=l-2
8721       endif
8722       do ll=1,3
8723 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8724 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8725 cgrad        ghalf=0.5d0*ggg1(ll)
8726 cd        ghalf=0.0d0
8727         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8728         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8729         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8730      &    +ekont*derx_turn(ll,2,1)
8731         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8732         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8733      &    +ekont*derx_turn(ll,4,1)
8734         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8735         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8736         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8737 cgrad        ghalf=0.5d0*ggg2(ll)
8738 cd        ghalf=0.0d0
8739         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8740      &    +ekont*derx_turn(ll,2,2)
8741         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8742         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8743      &    +ekont*derx_turn(ll,4,2)
8744         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8745         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8746         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8747       enddo
8748 cd      goto 1112
8749 cgrad      do m=i+1,j-1
8750 cgrad        do ll=1,3
8751 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8752 cgrad        enddo
8753 cgrad      enddo
8754 cgrad      do m=k+1,l-1
8755 cgrad        do ll=1,3
8756 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8757 cgrad        enddo
8758 cgrad      enddo
8759 cgrad1112  continue
8760 cgrad      do m=i+2,j2
8761 cgrad        do ll=1,3
8762 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8763 cgrad        enddo
8764 cgrad      enddo
8765 cgrad      do m=k+2,l2
8766 cgrad        do ll=1,3
8767 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8768 cgrad        enddo
8769 cgrad      enddo
8770 cd      do iii=1,nres-3
8771 cd        write (2,*) iii,g_corr6_loc(iii)
8772 cd      enddo
8773       eello_turn6=ekont*eel_turn6
8774 cd      write (2,*) 'ekont',ekont
8775 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8776       return
8777       end
8778
8779 C-----------------------------------------------------------------------------
8780       double precision function scalar(u,v)
8781 !DIR$ INLINEALWAYS scalar
8782 #ifndef OSF
8783 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8784 #endif
8785       implicit none
8786       double precision u(3),v(3)
8787 cd      double precision sc
8788 cd      integer i
8789 cd      sc=0.0d0
8790 cd      do i=1,3
8791 cd        sc=sc+u(i)*v(i)
8792 cd      enddo
8793 cd      scalar=sc
8794
8795       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8796       return
8797       end
8798 crc-------------------------------------------------
8799       SUBROUTINE MATVEC2(A1,V1,V2)
8800 !DIR$ INLINEALWAYS MATVEC2
8801 #ifndef OSF
8802 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8803 #endif
8804       implicit real*8 (a-h,o-z)
8805       include 'DIMENSIONS'
8806       DIMENSION A1(2,2),V1(2),V2(2)
8807 c      DO 1 I=1,2
8808 c        VI=0.0
8809 c        DO 3 K=1,2
8810 c    3     VI=VI+A1(I,K)*V1(K)
8811 c        Vaux(I)=VI
8812 c    1 CONTINUE
8813
8814       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8815       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8816
8817       v2(1)=vaux1
8818       v2(2)=vaux2
8819       END
8820 C---------------------------------------
8821       SUBROUTINE MATMAT2(A1,A2,A3)
8822 #ifndef OSF
8823 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8824 #endif
8825       implicit real*8 (a-h,o-z)
8826       include 'DIMENSIONS'
8827       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8828 c      DIMENSION AI3(2,2)
8829 c        DO  J=1,2
8830 c          A3IJ=0.0
8831 c          DO K=1,2
8832 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8833 c          enddo
8834 c          A3(I,J)=A3IJ
8835 c       enddo
8836 c      enddo
8837
8838       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8839       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8840       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8841       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8842
8843       A3(1,1)=AI3_11
8844       A3(2,1)=AI3_21
8845       A3(1,2)=AI3_12
8846       A3(2,2)=AI3_22
8847       END
8848
8849 c-------------------------------------------------------------------------
8850       double precision function scalar2(u,v)
8851 !DIR$ INLINEALWAYS scalar2
8852       implicit none
8853       double precision u(2),v(2)
8854       double precision sc
8855       integer i
8856       scalar2=u(1)*v(1)+u(2)*v(2)
8857       return
8858       end
8859
8860 C-----------------------------------------------------------------------------
8861
8862       subroutine transpose2(a,at)
8863 !DIR$ INLINEALWAYS transpose2
8864 #ifndef OSF
8865 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8866 #endif
8867       implicit none
8868       double precision a(2,2),at(2,2)
8869       at(1,1)=a(1,1)
8870       at(1,2)=a(2,1)
8871       at(2,1)=a(1,2)
8872       at(2,2)=a(2,2)
8873       return
8874       end
8875 c--------------------------------------------------------------------------
8876       subroutine transpose(n,a,at)
8877       implicit none
8878       integer n,i,j
8879       double precision a(n,n),at(n,n)
8880       do i=1,n
8881         do j=1,n
8882           at(j,i)=a(i,j)
8883         enddo
8884       enddo
8885       return
8886       end
8887 C---------------------------------------------------------------------------
8888       subroutine prodmat3(a1,a2,kk,transp,prod)
8889 !DIR$ INLINEALWAYS prodmat3
8890 #ifndef OSF
8891 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8892 #endif
8893       implicit none
8894       integer i,j
8895       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8896       logical transp
8897 crc      double precision auxmat(2,2),prod_(2,2)
8898
8899       if (transp) then
8900 crc        call transpose2(kk(1,1),auxmat(1,1))
8901 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8902 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8903
8904            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8905      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8906            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8907      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8908            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8909      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8910            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8911      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8912
8913       else
8914 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8915 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8916
8917            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8918      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8919            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8920      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8921            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8922      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8923            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8924      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8925
8926       endif
8927 c      call transpose2(a2(1,1),a2t(1,1))
8928
8929 crc      print *,transp
8930 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8931 crc      print *,((prod(i,j),i=1,2),j=1,2)
8932
8933       return
8934       end
8935