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),gloc_scbuf(3,maxres)
 445 #endif
 446       include 'COMMON.SETUP'
 447       include 'COMMON.IOUNITS'
 448       include 'COMMON.FFIELD'
 449       include 'COMMON.DERIV'
 450       include 'COMMON.INTERACT'
 451       include 'COMMON.SBRIDGE'
 452       include 'COMMON.CHAIN'
 453       include 'COMMON.VAR'
 454       include 'COMMON.CONTROL'
 455       include 'COMMON.TIME1'
 456       include 'COMMON.MAXGRAD'
 457       include 'COMMON.SCCOR'
 458 #ifdef TIMING
 459       time01=MPI_Wtime()
 460 #endif
 461 #ifdef DEBUG
 462       write (iout,*) "sum_gradient gvdwc, gvdwx"
 463       do i=1,nres
 464         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 465      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 466       enddo
 467       call flush(iout)
 468 #endif
 469 #ifdef MPI
 470 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 471         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 472      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 473 #endif
 474 C
 475 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 476 C            in virtual-bond-vector coordinates
 477 C
 478 #ifdef DEBUG
 479 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 482 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 483 c      enddo
 484 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 485 c      do i=1,nres-1
 486 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 487 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 488 c      enddo
 489       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 490       do i=1,nres
 491         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 492      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 493      &   g_corr5_loc(i)
 494       enddo
 495       call flush(iout)
 496 #endif
 497 #ifdef SPLITELE
 498       do i=1,nct
 499         do j=1,3
 500           gradbufc(j,i)=wsc*gvdwc(j,i)+
 501      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 502      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 503      &                wel_loc*gel_loc_long(j,i)+
 504      &                wcorr*gradcorr_long(j,i)+
 505      &                wcorr5*gradcorr5_long(j,i)+
 506      &                wcorr6*gradcorr6_long(j,i)+
 507      &                wturn6*gcorr6_turn_long(j,i)+
 508      &                wstrain*ghpbc(j,i)
 509         enddo
 510       enddo
 511 #else
 512       do i=1,nct
 513         do j=1,3
 514           gradbufc(j,i)=wsc*gvdwc(j,i)+
 515      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 516      &                welec*gelc_long(j,i)+
 517      &                wbond*gradb(j,i)+
 518      &                wel_loc*gel_loc_long(j,i)+
 519      &                wcorr*gradcorr_long(j,i)+
 520      &                wcorr5*gradcorr5_long(j,i)+
 521      &                wcorr6*gradcorr6_long(j,i)+
 522      &                wturn6*gcorr6_turn_long(j,i)+
 523      &                wstrain*ghpbc(j,i)
 524         enddo
 525       enddo
 526 #endif
 527 #ifdef MPI
 528       if (nfgtasks.gt.1) then
 529       time00=MPI_Wtime()
 530 #ifdef DEBUG
 531       write (iout,*) "gradbufc before allreduce"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 534       enddo
 535       call flush(iout)
 536 #endif
 537       do i=1,nres
 538         do j=1,3
 539           gradbufc_sum(j,i)=gradbufc(j,i)
 540         enddo
 541       enddo
 542 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 543 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 544 c      time_reduce=time_reduce+MPI_Wtime()-time00
 545 #ifdef DEBUG
 546 c      write (iout,*) "gradbufc_sum after allreduce"
 547 c      do i=1,nres
 548 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 549 c      enddo
 550 c      call flush(iout)
 551 #endif
 552 #ifdef TIMING
 553 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 554 #endif
 555       do i=nnt,nres
 556         do k=1,3
 557           gradbufc(k,i)=0.0d0
 558         enddo
 559       enddo
 560 #ifdef DEBUG
 561       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 562       write (iout,*) (i," jgrad_start",jgrad_start(i),
 563      &                  " jgrad_end  ",jgrad_end(i),
 564      &                  i=igrad_start,igrad_end)
 565 #endif
 566 c
 567 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 568 c do not parallelize this part.
 569 c
 570 c      do i=igrad_start,igrad_end
 571 c        do j=jgrad_start(i),jgrad_end(i)
 572 c          do k=1,3
 573 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 574 c          enddo
 575 c        enddo
 576 c      enddo
 577       do j=1,3
 578         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 579       enddo
 580       do i=nres-2,nnt,-1
 581         do j=1,3
 582           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 583         enddo
 584       enddo
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc after summing"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       else
 593 #endif
 594 #ifdef DEBUG
 595       write (iout,*) "gradbufc"
 596       do i=1,nres
 597         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 598       enddo
 599       call flush(iout)
 600 #endif
 601       do i=1,nres
 602         do j=1,3
 603           gradbufc_sum(j,i)=gradbufc(j,i)
 604           gradbufc(j,i)=0.0d0
 605         enddo
 606       enddo
 607       do j=1,3
 608         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 609       enddo
 610       do i=nres-2,nnt,-1
 611         do j=1,3
 612           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 613         enddo
 614       enddo
 615 c      do i=nnt,nres-1
 616 c        do k=1,3
 617 c          gradbufc(k,i)=0.0d0
 618 c        enddo
 619 c        do j=i+1,nres
 620 c          do k=1,3
 621 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 622 c          enddo
 623 c        enddo
 624 c      enddo
 625 #ifdef DEBUG
 626       write (iout,*) "gradbufc after summing"
 627       do i=1,nres
 628         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632 #ifdef MPI
 633       endif
 634 #endif
 635       do k=1,3
 636         gradbufc(k,nres)=0.0d0
 637       enddo
 638       do i=1,nct
 639         do j=1,3
 640 #ifdef SPLITELE
 641           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 642      &                wel_loc*gel_loc(j,i)+
 643      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 644      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 645      &                wel_loc*gel_loc_long(j,i)+
 646      &                wcorr*gradcorr_long(j,i)+
 647      &                wcorr5*gradcorr5_long(j,i)+
 648      &                wcorr6*gradcorr6_long(j,i)+
 649      &                wturn6*gcorr6_turn_long(j,i))+
 650      &                wbond*gradb(j,i)+
 651      &                wcorr*gradcorr(j,i)+
 652      &                wturn3*gcorr3_turn(j,i)+
 653      &                wturn4*gcorr4_turn(j,i)+
 654      &                wcorr5*gradcorr5(j,i)+
 655      &                wcorr6*gradcorr6(j,i)+
 656      &                wturn6*gcorr6_turn(j,i)+
 657      &                wsccor*gsccorc(j,i)
 658      &               +wscloc*gscloc(j,i)
 659 #else
 660           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 661      &                wel_loc*gel_loc(j,i)+
 662      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 663      &                welec*gelc_long(j,i)
 664      &                wel_loc*gel_loc_long(j,i)+
 665      &                wcorr*gcorr_long(j,i)+
 666      &                wcorr5*gradcorr5_long(j,i)+
 667      &                wcorr6*gradcorr6_long(j,i)+
 668      &                wturn6*gcorr6_turn_long(j,i))+
 669      &                wbond*gradb(j,i)+
 670      &                wcorr*gradcorr(j,i)+
 671      &                wturn3*gcorr3_turn(j,i)+
 672      &                wturn4*gcorr4_turn(j,i)+
 673      &                wcorr5*gradcorr5(j,i)+
 674      &                wcorr6*gradcorr6(j,i)+
 675      &                wturn6*gcorr6_turn(j,i)+
 676      &                wsccor*gsccorc(j,i)
 677      &               +wscloc*gscloc(j,i)
 678 #endif
 679           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 680      &                  wbond*gradbx(j,i)+
 681      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 682      &                  wsccor*gsccorx(j,i)
 683      &                 +wscloc*gsclocx(j,i)
 684         enddo
 685       enddo
 686 #ifdef DEBUG
 687       write (iout,*) "gloc before adding corr"
 688       do i=1,4*nres
 689         write (iout,*) i,gloc(i,icg)
 690       enddo
 691 #endif
 692       do i=1,nres-3
 693         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 694      &   +wcorr5*g_corr5_loc(i)
 695      &   +wcorr6*g_corr6_loc(i)
 696      &   +wturn4*gel_loc_turn4(i)
 697      &   +wturn3*gel_loc_turn3(i)
 698      &   +wturn6*gel_loc_turn6(i)
 699      &   +wel_loc*gel_loc_loc(i)
 700       enddo
 701 #ifdef DEBUG
 702       write (iout,*) "gloc after adding corr"
 703       do i=1,4*nres
 704         write (iout,*) i,gloc(i,icg)
 705       enddo
 706 #endif
 707 #ifdef MPI
 708       if (nfgtasks.gt.1) then
 709         do j=1,3
 710           do i=1,nres
 711             gradbufc(j,i)=gradc(j,i,icg)
 712             gradbufx(j,i)=gradx(j,i,icg)
 713           enddo
 714         enddo
 715         do i=1,4*nres
 716           glocbuf(i)=gloc(i,icg)
 717         enddo
 718 #define DEBUG
 719 #ifdef DEBUG
 720       write (iout,*) "gloc_sc before reduce"
 721       do i=1,nres
 722        do j=1,1
 723         write (iout,*) i,j,gloc_sc(j,i,icg)
 724        enddo
 725       enddo
 726 #endif
 727 #undef DEBUG
 728         do i=1,nres
 729          do j=1,3
 730           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 731          enddo
 732         enddo
 733         time00=MPI_Wtime()
 734         call MPI_Barrier(FG_COMM,IERR)
 735         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 736         time00=MPI_Wtime()
 737         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         time_reduce=time_reduce+MPI_Wtime()-time00
 744         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 746         time_reduce=time_reduce+MPI_Wtime()-time00
 747 #define DEBUG
 748 #ifdef DEBUG
 749       write (iout,*) "gloc_sc after reduce"
 750       do i=1,nres
 751        do j=1,1
 752         write (iout,*) i,j,gloc_sc(j,i,icg)
 753        enddo
 754       enddo
 755 #endif
 756 #undef DEBUG
 757 #ifdef DEBUG
 758       write (iout,*) "gloc after reduce"
 759       do i=1,4*nres
 760         write (iout,*) i,gloc(i,icg)
 761       enddo
 762 #endif
 763       endif
 764 #endif
 765       if (gnorm_check) then
 766 c
 767 c Compute the maximum elements of the gradient
 768 c
 769       gvdwc_max=0.0d0
 770       gvdwc_scp_max=0.0d0
 771       gelc_max=0.0d0
 772       gvdwpp_max=0.0d0
 773       gradb_max=0.0d0
 774       ghpbc_max=0.0d0
 775       gradcorr_max=0.0d0
 776       gel_loc_max=0.0d0
 777       gcorr3_turn_max=0.0d0
 778       gcorr4_turn_max=0.0d0
 779       gradcorr5_max=0.0d0
 780       gradcorr6_max=0.0d0
 781       gcorr6_turn_max=0.0d0
 782       gsccorc_max=0.0d0
 783       gscloc_max=0.0d0
 784       gvdwx_max=0.0d0
 785       gradx_scp_max=0.0d0
 786       ghpbx_max=0.0d0
 787       gradxorr_max=0.0d0
 788       gsccorx_max=0.0d0
 789       gsclocx_max=0.0d0
 790       do i=1,nct
 791         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 792         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 793         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 794         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 795      &   gvdwc_scp_max=gvdwc_scp_norm
 796         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 797         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 798         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 799         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 800         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 801         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 802         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 803         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 804         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 805         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 806         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 807         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 808         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 809      &    gcorr3_turn(1,i)))
 810         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 811      &    gcorr3_turn_max=gcorr3_turn_norm
 812         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 813      &    gcorr4_turn(1,i)))
 814         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 815      &    gcorr4_turn_max=gcorr4_turn_norm
 816         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 817         if (gradcorr5_norm.gt.gradcorr5_max)
 818      &    gradcorr5_max=gradcorr5_norm
 819         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 820         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 821         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 822      &    gcorr6_turn(1,i)))
 823         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 824      &    gcorr6_turn_max=gcorr6_turn_norm
 825         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 826         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 827         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 828         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 829         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 830         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 831         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 832         if (gradx_scp_norm.gt.gradx_scp_max)
 833      &    gradx_scp_max=gradx_scp_norm
 834         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 835         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 836         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 837         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 838         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 839         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 840         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 841         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 842       enddo
 843       if (gradout) then
 844 #ifdef AIX
 845         open(istat,file=statname,position="append")
 846 #else
 847         open(istat,file=statname,access="append")
 848 #endif
 849         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 850      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 851      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 852      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 853      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 854      &     gsccorx_max,gsclocx_max
 855         close(istat)
 856         if (gvdwc_max.gt.1.0d4) then
 857           write (iout,*) "gvdwc gvdwx gradb gradbx"
 858           do i=nnt,nct
 859             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 860      &        gradb(j,i),gradbx(j,i),j=1,3)
 861           enddo
 862           call pdbout(0.0d0,'cipiszcze',iout)
 863           call flush(iout)
 864         endif
 865       endif
 866       endif
 867 #ifdef DEBUG
 868       write (iout,*) "gradc gradx gloc"
 869       do i=1,nres
 870         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 871      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 872       enddo
 873 #endif
 874 #ifdef TIMING
 875       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 876 #endif
 877       return
 878       end
 879 c-------------------------------------------------------------------------------
 880       subroutine rescale_weights(t_bath)
 881       implicit real*8 (a-h,o-z)
 882       include 'DIMENSIONS'
 883       include 'COMMON.IOUNITS'
 884       include 'COMMON.FFIELD'
 885       include 'COMMON.SBRIDGE'
 886       double precision kfac /2.4d0/
 887       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 888 c      facT=temp0/t_bath
 889 c      facT=2*temp0/(t_bath+temp0)
 890       if (rescale_mode.eq.0) then
 891         facT=1.0d0
 892         facT2=1.0d0
 893         facT3=1.0d0
 894         facT4=1.0d0
 895         facT5=1.0d0
 896       else if (rescale_mode.eq.1) then
 897         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 898         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 899         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 900         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 901         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 902       else if (rescale_mode.eq.2) then
 903         x=t_bath/temp0
 904         x2=x*x
 905         x3=x2*x
 906         x4=x3*x
 907         x5=x4*x
 908         facT=licznik/dlog(dexp(x)+dexp(-x))
 909         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 910         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 911         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 912         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 913       else
 914         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 915         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 916 #ifdef MPI
 917        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 918 #endif
 919        stop 555
 920       endif
 921       welec=weights(3)*fact
 922       wcorr=weights(4)*fact3
 923       wcorr5=weights(5)*fact4
 924       wcorr6=weights(6)*fact5
 925       wel_loc=weights(7)*fact2
 926       wturn3=weights(8)*fact2
 927       wturn4=weights(9)*fact3
 928       wturn6=weights(10)*fact5
 929       wtor=weights(13)*fact
 930       wtor_d=weights(14)*fact2
 931       wsccor=weights(21)*fact
 932
 933       return
 934       end
 935 C------------------------------------------------------------------------
 936       subroutine enerprint(energia)
 937       implicit real*8 (a-h,o-z)
 938       include 'DIMENSIONS'
 939       include 'COMMON.IOUNITS'
 940       include 'COMMON.FFIELD'
 941       include 'COMMON.SBRIDGE'
 942       include 'COMMON.MD'
 943       double precision energia(0:n_ene)
 944       etot=energia(0)
 945       evdw=energia(1)
 946       evdw2=energia(2)
 947 #ifdef SCP14
 948       evdw2=energia(2)+energia(18)
 949 #else
 950       evdw2=energia(2)
 951 #endif
 952       ees=energia(3)
 953 #ifdef SPLITELE
 954       evdw1=energia(16)
 955 #endif
 956       ecorr=energia(4)
 957       ecorr5=energia(5)
 958       ecorr6=energia(6)
 959       eel_loc=energia(7)
 960       eello_turn3=energia(8)
 961       eello_turn4=energia(9)
 962       eello_turn6=energia(10)
 963       ebe=energia(11)
 964       escloc=energia(12)
 965       etors=energia(13)
 966       etors_d=energia(14)
 967       ehpb=energia(15)
 968       edihcnstr=energia(19)
 969       estr=energia(17)
 970       Uconst=energia(20)
 971       esccor=energia(21)
 972 #ifdef SPLITELE
 973       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 974      &  estr,wbond,ebe,wang,
 975      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 976      &  ecorr,wcorr,
 977      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 978      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 979      &  edihcnstr,ebr*nss,
 980      &  Uconst,etot
 981    10 format (/'Virtual-chain energies:'//
 982      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 983      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 984      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 985      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 986      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 987      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 988      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 989      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 990      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 991      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 992      & ' (SS bridges & dist. cnstr.)'/
 993      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 994      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 997      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 998      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 999      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1000      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1001      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1002      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1003      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1004      & 'ETOT=  ',1pE16.6,' (total)')
1005 #else
1006       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1007      &  estr,wbond,ebe,wang,
1008      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1009      &  ecorr,wcorr,
1010      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1011      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1012      &  ebr*nss,Uconst,etot
1013    10 format (/'Virtual-chain energies:'//
1014      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1015      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1016      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1017      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1018      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1019      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1020      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1021      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1022      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1023      & ' (SS bridges & dist. cnstr.)'/
1024      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1025      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1028      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1029      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1030      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1031      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1032      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1033      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1034      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1035      & 'ETOT=  ',1pE16.6,' (total)')
1036 #endif
1037       return
1038       end
1039 C-----------------------------------------------------------------------
1040       subroutine elj(evdw)
1041 C
1042 C This subroutine calculates the interaction energy of nonbonded side chains
1043 C assuming the LJ potential of interaction.
1044 C
1045       implicit real*8 (a-h,o-z)
1046       include 'DIMENSIONS'
1047       parameter (accur=1.0d-10)
1048       include 'COMMON.GEO'
1049       include 'COMMON.VAR'
1050       include 'COMMON.LOCAL'
1051       include 'COMMON.CHAIN'
1052       include 'COMMON.DERIV'
1053       include 'COMMON.INTERACT'
1054       include 'COMMON.TORSION'
1055       include 'COMMON.SBRIDGE'
1056       include 'COMMON.NAMES'
1057       include 'COMMON.IOUNITS'
1058       include 'COMMON.CONTACTS'
1059       dimension gg(3)
1060 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1061       evdw=0.0D0
1062       do i=iatsc_s,iatsc_e
1063         itypi=itype(i)
1064         if (itypi.eq.21) cycle
1065         itypi1=itype(i+1)
1066         xi=c(1,nres+i)
1067         yi=c(2,nres+i)
1068         zi=c(3,nres+i)
1069 C Change 12/1/95
1070         num_conti=0
1071 C
1072 C Calculate SC interaction energy.
1073 C
1074         do iint=1,nint_gr(i)
1075 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1076 cd   &                  'iend=',iend(i,iint)
1077           do j=istart(i,iint),iend(i,iint)
1078             itypj=itype(j)
1079             if (itypj.eq.21) cycle
1080             xj=c(1,nres+j)-xi
1081             yj=c(2,nres+j)-yi
1082             zj=c(3,nres+j)-zi
1083 C Change 12/1/95 to calculate four-body interactions
1084             rij=xj*xj+yj*yj+zj*zj
1085             rrij=1.0D0/rij
1086 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1087             eps0ij=eps(itypi,itypj)
1088             fac=rrij**expon2
1089             e1=fac*fac*aa(itypi,itypj)
1090             e2=fac*bb(itypi,itypj)
1091             evdwij=e1+e2
1092 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1093 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1094 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1095 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1096 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1097 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1098             evdw=evdw+evdwij
1099 C
1100 C Calculate the components of the gradient in DC and X
1101 C
1102             fac=-rrij*(e1+evdwij)
1103             gg(1)=xj*fac
1104             gg(2)=yj*fac
1105             gg(3)=zj*fac
1106             do k=1,3
1107               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1108               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1109               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1110               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1111             enddo
1112 cgrad            do k=i,j-1
1113 cgrad              do l=1,3
1114 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1115 cgrad              enddo
1116 cgrad            enddo
1117 C
1118 C 12/1/95, revised on 5/20/97
1119 C
1120 C Calculate the contact function. The ith column of the array JCONT will
1121 C contain the numbers of atoms that make contacts with the atom I (of numbers
1122 C greater than I). The arrays FACONT and GACONT will contain the values of
1123 C the contact function and its derivative.
1124 C
1125 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1126 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1127 C Uncomment next line, if the correlation interactions are contact function only
1128             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1129               rij=dsqrt(rij)
1130               sigij=sigma(itypi,itypj)
1131               r0ij=rs0(itypi,itypj)
1132 C
1133 C Check whether the SC's are not too far to make a contact.
1134 C
1135               rcut=1.5d0*r0ij
1136               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1137 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1138 C
1139               if (fcont.gt.0.0D0) then
1140 C If the SC-SC distance if close to sigma, apply spline.
1141 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1142 cAdam &             fcont1,fprimcont1)
1143 cAdam           fcont1=1.0d0-fcont1
1144 cAdam           if (fcont1.gt.0.0d0) then
1145 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1146 cAdam             fcont=fcont*fcont1
1147 cAdam           endif
1148 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1149 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1150 cga             do k=1,3
1151 cga               gg(k)=gg(k)*eps0ij
1152 cga             enddo
1153 cga             eps0ij=-evdwij*eps0ij
1154 C Uncomment for AL's type of SC correlation interactions.
1155 cadam           eps0ij=-evdwij
1156                 num_conti=num_conti+1
1157                 jcont(num_conti,i)=j
1158                 facont(num_conti,i)=fcont*eps0ij
1159                 fprimcont=eps0ij*fprimcont/rij
1160                 fcont=expon*fcont
1161 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1162 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1163 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1164 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1165                 gacont(1,num_conti,i)=-fprimcont*xj
1166                 gacont(2,num_conti,i)=-fprimcont*yj
1167                 gacont(3,num_conti,i)=-fprimcont*zj
1168 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1169 cd              write (iout,'(2i3,3f10.5)')
1170 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1171               endif
1172             endif
1173           enddo      ! j
1174         enddo        ! iint
1175 C Change 12/1/95
1176         num_cont(i)=num_conti
1177       enddo          ! i
1178       do i=1,nct
1179         do j=1,3
1180           gvdwc(j,i)=expon*gvdwc(j,i)
1181           gvdwx(j,i)=expon*gvdwx(j,i)
1182         enddo
1183       enddo
1184 C******************************************************************************
1185 C
1186 C                              N O T E !!!
1187 C
1188 C To save time, the factor of EXPON has been extracted from ALL components
1189 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1190 C use!
1191 C
1192 C******************************************************************************
1193       return
1194       end
1195 C-----------------------------------------------------------------------------
1196       subroutine eljk(evdw)
1197 C
1198 C This subroutine calculates the interaction energy of nonbonded side chains
1199 C assuming the LJK potential of interaction.
1200 C
1201       implicit real*8 (a-h,o-z)
1202       include 'DIMENSIONS'
1203       include 'COMMON.GEO'
1204       include 'COMMON.VAR'
1205       include 'COMMON.LOCAL'
1206       include 'COMMON.CHAIN'
1207       include 'COMMON.DERIV'
1208       include 'COMMON.INTERACT'
1209       include 'COMMON.IOUNITS'
1210       include 'COMMON.NAMES'
1211       dimension gg(3)
1212       logical scheck
1213 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1214       evdw=0.0D0
1215       do i=iatsc_s,iatsc_e
1216         itypi=itype(i)
1217         if (itypi.eq.21) cycle
1218         itypi1=itype(i+1)
1219         xi=c(1,nres+i)
1220         yi=c(2,nres+i)
1221         zi=c(3,nres+i)
1222 C
1223 C Calculate SC interaction energy.
1224 C
1225         do iint=1,nint_gr(i)
1226           do j=istart(i,iint),iend(i,iint)
1227             itypj=itype(j)
1228             if (itypj.eq.21) cycle
1229             xj=c(1,nres+j)-xi
1230             yj=c(2,nres+j)-yi
1231             zj=c(3,nres+j)-zi
1232             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1233             fac_augm=rrij**expon
1234             e_augm=augm(itypi,itypj)*fac_augm
1235             r_inv_ij=dsqrt(rrij)
1236             rij=1.0D0/r_inv_ij
1237             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1238             fac=r_shift_inv**expon
1239             e1=fac*fac*aa(itypi,itypj)
1240             e2=fac*bb(itypi,itypj)
1241             evdwij=e_augm+e1+e2
1242 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1243 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1244 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1245 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1246 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1247 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1248 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1249             evdw=evdw+evdwij
1250 C
1251 C Calculate the components of the gradient in DC and X
1252 C
1253             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1254             gg(1)=xj*fac
1255             gg(2)=yj*fac
1256             gg(3)=zj*fac
1257             do k=1,3
1258               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1259               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1260               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1261               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1262             enddo
1263 cgrad            do k=i,j-1
1264 cgrad              do l=1,3
1265 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1266 cgrad              enddo
1267 cgrad            enddo
1268           enddo      ! j
1269         enddo        ! iint
1270       enddo          ! i
1271       do i=1,nct
1272         do j=1,3
1273           gvdwc(j,i)=expon*gvdwc(j,i)
1274           gvdwx(j,i)=expon*gvdwx(j,i)
1275         enddo
1276       enddo
1277       return
1278       end
1279 C-----------------------------------------------------------------------------
1280       subroutine ebp(evdw)
1281 C
1282 C This subroutine calculates the interaction energy of nonbonded side chains
1283 C assuming the Berne-Pechukas potential of interaction.
1284 C
1285       implicit real*8 (a-h,o-z)
1286       include 'DIMENSIONS'
1287       include 'COMMON.GEO'
1288       include 'COMMON.VAR'
1289       include 'COMMON.LOCAL'
1290       include 'COMMON.CHAIN'
1291       include 'COMMON.DERIV'
1292       include 'COMMON.NAMES'
1293       include 'COMMON.INTERACT'
1294       include 'COMMON.IOUNITS'
1295       include 'COMMON.CALC'
1296       common /srutu/ icall
1297 c     double precision rrsave(maxdim)
1298       logical lprn
1299       evdw=0.0D0
1300 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1301       evdw=0.0D0
1302 c     if (icall.eq.0) then
1303 c       lprn=.true.
1304 c     else
1305         lprn=.false.
1306 c     endif
1307       ind=0
1308       do i=iatsc_s,iatsc_e
1309         itypi=itype(i)
1310         if (itypi.eq.21) cycle
1311         itypi1=itype(i+1)
1312         xi=c(1,nres+i)
1313         yi=c(2,nres+i)
1314         zi=c(3,nres+i)
1315         dxi=dc_norm(1,nres+i)
1316         dyi=dc_norm(2,nres+i)
1317         dzi=dc_norm(3,nres+i)
1318 c        dsci_inv=dsc_inv(itypi)
1319         dsci_inv=vbld_inv(i+nres)
1320 C
1321 C Calculate SC interaction energy.
1322 C
1323         do iint=1,nint_gr(i)
1324           do j=istart(i,iint),iend(i,iint)
1325             ind=ind+1
1326             itypj=itype(j)
1327             if (itypj.eq.21) cycle
1328 c            dscj_inv=dsc_inv(itypj)
1329             dscj_inv=vbld_inv(j+nres)
1330             chi1=chi(itypi,itypj)
1331             chi2=chi(itypj,itypi)
1332             chi12=chi1*chi2
1333             chip1=chip(itypi)
1334             chip2=chip(itypj)
1335             chip12=chip1*chip2
1336             alf1=alp(itypi)
1337             alf2=alp(itypj)
1338             alf12=0.5D0*(alf1+alf2)
1339 C For diagnostics only!!!
1340 c           chi1=0.0D0
1341 c           chi2=0.0D0
1342 c           chi12=0.0D0
1343 c           chip1=0.0D0
1344 c           chip2=0.0D0
1345 c           chip12=0.0D0
1346 c           alf1=0.0D0
1347 c           alf2=0.0D0
1348 c           alf12=0.0D0
1349             xj=c(1,nres+j)-xi
1350             yj=c(2,nres+j)-yi
1351             zj=c(3,nres+j)-zi
1352             dxj=dc_norm(1,nres+j)
1353             dyj=dc_norm(2,nres+j)
1354             dzj=dc_norm(3,nres+j)
1355             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1356 cd          if (icall.eq.0) then
1357 cd            rrsave(ind)=rrij
1358 cd          else
1359 cd            rrij=rrsave(ind)
1360 cd          endif
1361             rij=dsqrt(rrij)
1362 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1363             call sc_angular
1364 C Calculate whole angle-dependent part of epsilon and contributions
1365 C to its derivatives
1366             fac=(rrij*sigsq)**expon2
1367             e1=fac*fac*aa(itypi,itypj)
1368             e2=fac*bb(itypi,itypj)
1369             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1370             eps2der=evdwij*eps3rt
1371             eps3der=evdwij*eps2rt
1372             evdwij=evdwij*eps2rt*eps3rt
1373             evdw=evdw+evdwij
1374             if (lprn) then
1375             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1376             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1377 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1378 cd     &        restyp(itypi),i,restyp(itypj),j,
1379 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1380 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1381 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1382 cd     &        evdwij
1383             endif
1384 C Calculate gradient components.
1385             e1=e1*eps1*eps2rt**2*eps3rt**2
1386             fac=-expon*(e1+evdwij)
1387             sigder=fac/sigsq
1388             fac=rrij*fac
1389 C Calculate radial part of the gradient
1390             gg(1)=xj*fac
1391             gg(2)=yj*fac
1392             gg(3)=zj*fac
1393 C Calculate the angular part of the gradient and sum add the contributions
1394 C to the appropriate components of the Cartesian gradient.
1395             call sc_grad
1396           enddo      ! j
1397         enddo        ! iint
1398       enddo          ! i
1399 c     stop
1400       return
1401       end
1402 C-----------------------------------------------------------------------------
1403       subroutine egb(evdw)
1404 C
1405 C This subroutine calculates the interaction energy of nonbonded side chains
1406 C assuming the Gay-Berne potential of interaction.
1407 C
1408       implicit real*8 (a-h,o-z)
1409       include 'DIMENSIONS'
1410       include 'COMMON.GEO'
1411       include 'COMMON.VAR'
1412       include 'COMMON.LOCAL'
1413       include 'COMMON.CHAIN'
1414       include 'COMMON.DERIV'
1415       include 'COMMON.NAMES'
1416       include 'COMMON.INTERACT'
1417       include 'COMMON.IOUNITS'
1418       include 'COMMON.CALC'
1419       include 'COMMON.CONTROL'
1420       include 'COMMON.SBRIDGE'
1421       logical lprn
1422       evdw=0.0D0
1423 ccccc      energy_dec=.false.
1424 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1425       evdw=0.0D0
1426       lprn=.false.
1427 c     if (icall.eq.0) lprn=.false.
1428       ind=0
1429       do i=iatsc_s,iatsc_e
1430         itypi=itype(i)
1431         if (itypi.eq.21) cycle
1432         itypi1=itype(i+1)
1433         xi=c(1,nres+i)
1434         yi=c(2,nres+i)
1435         zi=c(3,nres+i)
1436         dxi=dc_norm(1,nres+i)
1437         dyi=dc_norm(2,nres+i)
1438         dzi=dc_norm(3,nres+i)
1439 c        dsci_inv=dsc_inv(itypi)
1440         dsci_inv=vbld_inv(i+nres)
1441 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1442 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1443 C
1444 C Calculate SC interaction energy.
1445 C
1446         do iint=1,nint_gr(i)
1447           do j=istart(i,iint),iend(i,iint)
1448             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1449               call dyn_ssbond_ene(i,j,evdwij)
1450               evdw=evdw+evdwij
1451               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1452      &                        'evdw',i,j,evdwij,' ss'
1453             ELSE
1454             ind=ind+1
1455             itypj=itype(j)
1456             if (itypj.eq.21) cycle
1457 c            dscj_inv=dsc_inv(itypj)
1458             dscj_inv=vbld_inv(j+nres)
1459 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1460 c     &       1.0d0/vbld(j+nres)
1461 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1462             sig0ij=sigma(itypi,itypj)
1463             chi1=chi(itypi,itypj)
1464             chi2=chi(itypj,itypi)
1465             chi12=chi1*chi2
1466             chip1=chip(itypi)
1467             chip2=chip(itypj)
1468             chip12=chip1*chip2
1469             alf1=alp(itypi)
1470             alf2=alp(itypj)
1471             alf12=0.5D0*(alf1+alf2)
1472 C For diagnostics only!!!
1473 c           chi1=0.0D0
1474 c           chi2=0.0D0
1475 c           chi12=0.0D0
1476 c           chip1=0.0D0
1477 c           chip2=0.0D0
1478 c           chip12=0.0D0
1479 c           alf1=0.0D0
1480 c           alf2=0.0D0
1481 c           alf12=0.0D0
1482             xj=c(1,nres+j)-xi
1483             yj=c(2,nres+j)-yi
1484             zj=c(3,nres+j)-zi
1485             dxj=dc_norm(1,nres+j)
1486             dyj=dc_norm(2,nres+j)
1487             dzj=dc_norm(3,nres+j)
1488 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1489 c            write (iout,*) "j",j," dc_norm",
1490 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1491             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1492             rij=dsqrt(rrij)
1493 C Calculate angle-dependent terms of energy and contributions to their
1494 C derivatives.
1495             call sc_angular
1496             sigsq=1.0D0/sigsq
1497             sig=sig0ij*dsqrt(sigsq)
1498             rij_shift=1.0D0/rij-sig+sig0ij
1499 c for diagnostics; uncomment
1500 c            rij_shift=1.2*sig0ij
1501 C I hate to put IF's in the loops, but here don't have another choice!!!!
1502             if (rij_shift.le.0.0D0) then
1503               evdw=1.0D20
1504 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1505 cd     &        restyp(itypi),i,restyp(itypj),j,
1506 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1507               return
1508             endif
1509             sigder=-sig*sigsq
1510 c---------------------------------------------------------------
1511             rij_shift=1.0D0/rij_shift
1512             fac=rij_shift**expon
1513             e1=fac*fac*aa(itypi,itypj)
1514             e2=fac*bb(itypi,itypj)
1515             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1516             eps2der=evdwij*eps3rt
1517             eps3der=evdwij*eps2rt
1518 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1519 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1520             evdwij=evdwij*eps2rt*eps3rt
1521             evdw=evdw+evdwij
1522             if (lprn) then
1523             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1524             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1525             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1526      &        restyp(itypi),i,restyp(itypj),j,
1527      &        epsi,sigm,chi1,chi2,chip1,chip2,
1528      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1529      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1530      &        evdwij
1531             endif
1532
1533             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1534      &                        'evdw',i,j,evdwij
1535
1536 C Calculate gradient components.
1537             e1=e1*eps1*eps2rt**2*eps3rt**2
1538             fac=-expon*(e1+evdwij)*rij_shift
1539             sigder=fac*sigder
1540             fac=rij*fac
1541 c            fac=0.0d0
1542 C Calculate the radial part of the gradient
1543             gg(1)=xj*fac
1544             gg(2)=yj*fac
1545             gg(3)=zj*fac
1546 C Calculate angular part of the gradient.
1547             call sc_grad
1548             ENDIF    ! dyn_ss
1549           enddo      ! j
1550         enddo        ! iint
1551       enddo          ! i
1552 c      write (iout,*) "Number of loop steps in EGB:",ind
1553 cccc      energy_dec=.false.
1554       return
1555       end
1556 C-----------------------------------------------------------------------------
1557       subroutine egbv(evdw)
1558 C
1559 C This subroutine calculates the interaction energy of nonbonded side chains
1560 C assuming the Gay-Berne-Vorobjev potential of interaction.
1561 C
1562       implicit real*8 (a-h,o-z)
1563       include 'DIMENSIONS'
1564       include 'COMMON.GEO'
1565       include 'COMMON.VAR'
1566       include 'COMMON.LOCAL'
1567       include 'COMMON.CHAIN'
1568       include 'COMMON.DERIV'
1569       include 'COMMON.NAMES'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.IOUNITS'
1572       include 'COMMON.CALC'
1573       common /srutu/ icall
1574       logical lprn
1575       evdw=0.0D0
1576 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1577       evdw=0.0D0
1578       lprn=.false.
1579 c     if (icall.eq.0) lprn=.true.
1580       ind=0
1581       do i=iatsc_s,iatsc_e
1582         itypi=itype(i)
1583         if (itypi.eq.21) cycle
1584         itypi1=itype(i+1)
1585         xi=c(1,nres+i)
1586         yi=c(2,nres+i)
1587         zi=c(3,nres+i)
1588         dxi=dc_norm(1,nres+i)
1589         dyi=dc_norm(2,nres+i)
1590         dzi=dc_norm(3,nres+i)
1591 c        dsci_inv=dsc_inv(itypi)
1592         dsci_inv=vbld_inv(i+nres)
1593 C
1594 C Calculate SC interaction energy.
1595 C
1596         do iint=1,nint_gr(i)
1597           do j=istart(i,iint),iend(i,iint)
1598             ind=ind+1
1599             itypj=itype(j)
1600             if (itypj.eq.21) cycle
1601 c            dscj_inv=dsc_inv(itypj)
1602             dscj_inv=vbld_inv(j+nres)
1603             sig0ij=sigma(itypi,itypj)
1604             r0ij=r0(itypi,itypj)
1605             chi1=chi(itypi,itypj)
1606             chi2=chi(itypj,itypi)
1607             chi12=chi1*chi2
1608             chip1=chip(itypi)
1609             chip2=chip(itypj)
1610             chip12=chip1*chip2
1611             alf1=alp(itypi)
1612             alf2=alp(itypj)
1613             alf12=0.5D0*(alf1+alf2)
1614 C For diagnostics only!!!
1615 c           chi1=0.0D0
1616 c           chi2=0.0D0
1617 c           chi12=0.0D0
1618 c           chip1=0.0D0
1619 c           chip2=0.0D0
1620 c           chip12=0.0D0
1621 c           alf1=0.0D0
1622 c           alf2=0.0D0
1623 c           alf12=0.0D0
1624             xj=c(1,nres+j)-xi
1625             yj=c(2,nres+j)-yi
1626             zj=c(3,nres+j)-zi
1627             dxj=dc_norm(1,nres+j)
1628             dyj=dc_norm(2,nres+j)
1629             dzj=dc_norm(3,nres+j)
1630             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1631             rij=dsqrt(rrij)
1632 C Calculate angle-dependent terms of energy and contributions to their
1633 C derivatives.
1634             call sc_angular
1635             sigsq=1.0D0/sigsq
1636             sig=sig0ij*dsqrt(sigsq)
1637             rij_shift=1.0D0/rij-sig+r0ij
1638 C I hate to put IF's in the loops, but here don't have another choice!!!!
1639             if (rij_shift.le.0.0D0) then
1640               evdw=1.0D20
1641               return
1642             endif
1643             sigder=-sig*sigsq
1644 c---------------------------------------------------------------
1645             rij_shift=1.0D0/rij_shift
1646             fac=rij_shift**expon
1647             e1=fac*fac*aa(itypi,itypj)
1648             e2=fac*bb(itypi,itypj)
1649             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1650             eps2der=evdwij*eps3rt
1651             eps3der=evdwij*eps2rt
1652             fac_augm=rrij**expon
1653             e_augm=augm(itypi,itypj)*fac_augm
1654             evdwij=evdwij*eps2rt*eps3rt
1655             evdw=evdw+evdwij+e_augm
1656             if (lprn) then
1657             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1658             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1659             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1660      &        restyp(itypi),i,restyp(itypj),j,
1661      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1662      &        chi1,chi2,chip1,chip2,
1663      &        eps1,eps2rt**2,eps3rt**2,
1664      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1665      &        evdwij+e_augm
1666             endif
1667 C Calculate gradient components.
1668             e1=e1*eps1*eps2rt**2*eps3rt**2
1669             fac=-expon*(e1+evdwij)*rij_shift
1670             sigder=fac*sigder
1671             fac=rij*fac-2*expon*rrij*e_augm
1672 C Calculate the radial part of the gradient
1673             gg(1)=xj*fac
1674             gg(2)=yj*fac
1675             gg(3)=zj*fac
1676 C Calculate angular part of the gradient.
1677             call sc_grad
1678           enddo      ! j
1679         enddo        ! iint
1680       enddo          ! i
1681       end
1682 C-----------------------------------------------------------------------------
1683       subroutine sc_angular
1684 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1685 C om12. Called by ebp, egb, and egbv.
1686       implicit none
1687       include 'COMMON.CALC'
1688       include 'COMMON.IOUNITS'
1689       erij(1)=xj*rij
1690       erij(2)=yj*rij
1691       erij(3)=zj*rij
1692       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1693       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1694       om12=dxi*dxj+dyi*dyj+dzi*dzj
1695       chiom12=chi12*om12
1696 C Calculate eps1(om12) and its derivative in om12
1697       faceps1=1.0D0-om12*chiom12
1698       faceps1_inv=1.0D0/faceps1
1699       eps1=dsqrt(faceps1_inv)
1700 C Following variable is eps1*deps1/dom12
1701       eps1_om12=faceps1_inv*chiom12
1702 c diagnostics only
1703 c      faceps1_inv=om12
1704 c      eps1=om12
1705 c      eps1_om12=1.0d0
1706 c      write (iout,*) "om12",om12," eps1",eps1
1707 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1708 C and om12.
1709       om1om2=om1*om2
1710       chiom1=chi1*om1
1711       chiom2=chi2*om2
1712       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1713       sigsq=1.0D0-facsig*faceps1_inv
1714       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1715       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1716       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1717 c diagnostics only
1718 c      sigsq=1.0d0
1719 c      sigsq_om1=0.0d0
1720 c      sigsq_om2=0.0d0
1721 c      sigsq_om12=0.0d0
1722 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1723 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1724 c     &    " eps1",eps1
1725 C Calculate eps2 and its derivatives in om1, om2, and om12.
1726       chipom1=chip1*om1
1727       chipom2=chip2*om2
1728       chipom12=chip12*om12
1729       facp=1.0D0-om12*chipom12
1730       facp_inv=1.0D0/facp
1731       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1732 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1733 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1734 C Following variable is the square root of eps2
1735       eps2rt=1.0D0-facp1*facp_inv
1736 C Following three variables are the derivatives of the square root of eps
1737 C in om1, om2, and om12.
1738       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1739       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1740       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1741 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1742       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1743 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1744 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1745 c     &  " eps2rt_om12",eps2rt_om12
1746 C Calculate whole angle-dependent part of epsilon and contributions
1747 C to its derivatives
1748       return
1749       end
1750 C----------------------------------------------------------------------------
1751       subroutine sc_grad
1752       implicit real*8 (a-h,o-z)
1753       include 'DIMENSIONS'
1754       include 'COMMON.CHAIN'
1755       include 'COMMON.DERIV'
1756       include 'COMMON.CALC'
1757       include 'COMMON.IOUNITS'
1758       double precision dcosom1(3),dcosom2(3)
1759       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1760       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1761       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1762      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1763 c diagnostics only
1764 c      eom1=0.0d0
1765 c      eom2=0.0d0
1766 c      eom12=evdwij*eps1_om12
1767 c end diagnostics
1768 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1769 c     &  " sigder",sigder
1770 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1771 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1772       do k=1,3
1773         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1774         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1775       enddo
1776       do k=1,3
1777         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1778       enddo
1779 c      write (iout,*) "gg",(gg(k),k=1,3)
1780       do k=1,3
1781         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1782      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1783      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1784         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1785      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1786      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1787 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1788 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1789 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1790 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1791       enddo
1792 C
1793 C Calculate the components of the gradient in DC and X
1794 C
1795 cgrad      do k=i,j-1
1796 cgrad        do l=1,3
1797 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1798 cgrad        enddo
1799 cgrad      enddo
1800       do l=1,3
1801         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1802         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1803       enddo
1804       return
1805       end
1806 C-----------------------------------------------------------------------
1807       subroutine e_softsphere(evdw)
1808 C
1809 C This subroutine calculates the interaction energy of nonbonded side chains
1810 C assuming the LJ potential of interaction.
1811 C
1812       implicit real*8 (a-h,o-z)
1813       include 'DIMENSIONS'
1814       parameter (accur=1.0d-10)
1815       include 'COMMON.GEO'
1816       include 'COMMON.VAR'
1817       include 'COMMON.LOCAL'
1818       include 'COMMON.CHAIN'
1819       include 'COMMON.DERIV'
1820       include 'COMMON.INTERACT'
1821       include 'COMMON.TORSION'
1822       include 'COMMON.SBRIDGE'
1823       include 'COMMON.NAMES'
1824       include 'COMMON.IOUNITS'
1825       include 'COMMON.CONTACTS'
1826       dimension gg(3)
1827 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1828       evdw=0.0D0
1829       do i=iatsc_s,iatsc_e
1830         itypi=itype(i)
1831         if (itypi.eq.21) cycle
1832         itypi1=itype(i+1)
1833         xi=c(1,nres+i)
1834         yi=c(2,nres+i)
1835         zi=c(3,nres+i)
1836 C
1837 C Calculate SC interaction energy.
1838 C
1839         do iint=1,nint_gr(i)
1840 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1841 cd   &                  'iend=',iend(i,iint)
1842           do j=istart(i,iint),iend(i,iint)
1843             itypj=itype(j)
1844             if (itypj.eq.21) cycle
1845             xj=c(1,nres+j)-xi
1846             yj=c(2,nres+j)-yi
1847             zj=c(3,nres+j)-zi
1848             rij=xj*xj+yj*yj+zj*zj
1849 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1850             r0ij=r0(itypi,itypj)
1851             r0ijsq=r0ij*r0ij
1852 c            print *,i,j,r0ij,dsqrt(rij)
1853             if (rij.lt.r0ijsq) then
1854               evdwij=0.25d0*(rij-r0ijsq)**2
1855               fac=rij-r0ijsq
1856             else
1857               evdwij=0.0d0
1858               fac=0.0d0
1859             endif
1860             evdw=evdw+evdwij
1861 C
1862 C Calculate the components of the gradient in DC and X
1863 C
1864             gg(1)=xj*fac
1865             gg(2)=yj*fac
1866             gg(3)=zj*fac
1867             do k=1,3
1868               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1869               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1870               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1871               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1872             enddo
1873 cgrad            do k=i,j-1
1874 cgrad              do l=1,3
1875 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1876 cgrad              enddo
1877 cgrad            enddo
1878           enddo ! j
1879         enddo ! iint
1880       enddo ! i
1881       return
1882       end
1883 C--------------------------------------------------------------------------
1884       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1885      &              eello_turn4)
1886 C
1887 C Soft-sphere potential of p-p interaction
1888 C
1889       implicit real*8 (a-h,o-z)
1890       include 'DIMENSIONS'
1891       include 'COMMON.CONTROL'
1892       include 'COMMON.IOUNITS'
1893       include 'COMMON.GEO'
1894       include 'COMMON.VAR'
1895       include 'COMMON.LOCAL'
1896       include 'COMMON.CHAIN'
1897       include 'COMMON.DERIV'
1898       include 'COMMON.INTERACT'
1899       include 'COMMON.CONTACTS'
1900       include 'COMMON.TORSION'
1901       include 'COMMON.VECTORS'
1902       include 'COMMON.FFIELD'
1903       dimension ggg(3)
1904 cd      write(iout,*) 'In EELEC_soft_sphere'
1905       ees=0.0D0
1906       evdw1=0.0D0
1907       eel_loc=0.0d0
1908       eello_turn3=0.0d0
1909       eello_turn4=0.0d0
1910       ind=0
1911       do i=iatel_s,iatel_e
1912         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1913         dxi=dc(1,i)
1914         dyi=dc(2,i)
1915         dzi=dc(3,i)
1916         xmedi=c(1,i)+0.5d0*dxi
1917         ymedi=c(2,i)+0.5d0*dyi
1918         zmedi=c(3,i)+0.5d0*dzi
1919         num_conti=0
1920 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1921         do j=ielstart(i),ielend(i)
1922           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1923           ind=ind+1
1924           iteli=itel(i)
1925           itelj=itel(j)
1926           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1927           r0ij=rpp(iteli,itelj)
1928           r0ijsq=r0ij*r0ij
1929           dxj=dc(1,j)
1930           dyj=dc(2,j)
1931           dzj=dc(3,j)
1932           xj=c(1,j)+0.5D0*dxj-xmedi
1933           yj=c(2,j)+0.5D0*dyj-ymedi
1934           zj=c(3,j)+0.5D0*dzj-zmedi
1935           rij=xj*xj+yj*yj+zj*zj
1936           if (rij.lt.r0ijsq) then
1937             evdw1ij=0.25d0*(rij-r0ijsq)**2
1938             fac=rij-r0ijsq
1939           else
1940             evdw1ij=0.0d0
1941             fac=0.0d0
1942           endif
1943           evdw1=evdw1+evdw1ij
1944 C
1945 C Calculate contributions to the Cartesian gradient.
1946 C
1947           ggg(1)=fac*xj
1948           ggg(2)=fac*yj
1949           ggg(3)=fac*zj
1950           do k=1,3
1951             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1952             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1953           enddo
1954 *
1955 * Loop over residues i+1 thru j-1.
1956 *
1957 cgrad          do k=i+1,j-1
1958 cgrad            do l=1,3
1959 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1960 cgrad            enddo
1961 cgrad          enddo
1962         enddo ! j
1963       enddo   ! i
1964 cgrad      do i=nnt,nct-1
1965 cgrad        do k=1,3
1966 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1967 cgrad        enddo
1968 cgrad        do j=i+1,nct-1
1969 cgrad          do k=1,3
1970 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1971 cgrad          enddo
1972 cgrad        enddo
1973 cgrad      enddo
1974       return
1975       end
1976 c------------------------------------------------------------------------------
1977       subroutine vec_and_deriv
1978       implicit real*8 (a-h,o-z)
1979       include 'DIMENSIONS'
1980 #ifdef MPI
1981       include 'mpif.h'
1982 #endif
1983       include 'COMMON.IOUNITS'
1984       include 'COMMON.GEO'
1985       include 'COMMON.VAR'
1986       include 'COMMON.LOCAL'
1987       include 'COMMON.CHAIN'
1988       include 'COMMON.VECTORS'
1989       include 'COMMON.SETUP'
1990       include 'COMMON.TIME1'
1991       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1992 C Compute the local reference systems. For reference system (i), the
1993 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1994 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1995 #ifdef PARVEC
1996       do i=ivec_start,ivec_end
1997 #else
1998       do i=1,nres-1
1999 #endif
2000           if (i.eq.nres-1) then
2001 C Case of the last full residue
2002 C Compute the Z-axis
2003             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2004             costh=dcos(pi-theta(nres))
2005             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2006             do k=1,3
2007               uz(k,i)=fac*uz(k,i)
2008             enddo
2009 C Compute the derivatives of uz
2010             uzder(1,1,1)= 0.0d0
2011             uzder(2,1,1)=-dc_norm(3,i-1)
2012             uzder(3,1,1)= dc_norm(2,i-1)
2013             uzder(1,2,1)= dc_norm(3,i-1)
2014             uzder(2,2,1)= 0.0d0
2015             uzder(3,2,1)=-dc_norm(1,i-1)
2016             uzder(1,3,1)=-dc_norm(2,i-1)
2017             uzder(2,3,1)= dc_norm(1,i-1)
2018             uzder(3,3,1)= 0.0d0
2019             uzder(1,1,2)= 0.0d0
2020             uzder(2,1,2)= dc_norm(3,i)
2021             uzder(3,1,2)=-dc_norm(2,i)
2022             uzder(1,2,2)=-dc_norm(3,i)
2023             uzder(2,2,2)= 0.0d0
2024             uzder(3,2,2)= dc_norm(1,i)
2025             uzder(1,3,2)= dc_norm(2,i)
2026             uzder(2,3,2)=-dc_norm(1,i)
2027             uzder(3,3,2)= 0.0d0
2028 C Compute the Y-axis
2029             facy=fac
2030             do k=1,3
2031               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2032             enddo
2033 C Compute the derivatives of uy
2034             do j=1,3
2035               do k=1,3
2036                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2037      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2038                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2039               enddo
2040               uyder(j,j,1)=uyder(j,j,1)-costh
2041               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2042             enddo
2043             do j=1,2
2044               do k=1,3
2045                 do l=1,3
2046                   uygrad(l,k,j,i)=uyder(l,k,j)
2047                   uzgrad(l,k,j,i)=uzder(l,k,j)
2048                 enddo
2049               enddo
2050             enddo
2051             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2052             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2053             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2054             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2055           else
2056 C Other residues
2057 C Compute the Z-axis
2058             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2059             costh=dcos(pi-theta(i+2))
2060             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2061             do k=1,3
2062               uz(k,i)=fac*uz(k,i)
2063             enddo
2064 C Compute the derivatives of uz
2065             uzder(1,1,1)= 0.0d0
2066             uzder(2,1,1)=-dc_norm(3,i+1)
2067             uzder(3,1,1)= dc_norm(2,i+1)
2068             uzder(1,2,1)= dc_norm(3,i+1)
2069             uzder(2,2,1)= 0.0d0
2070             uzder(3,2,1)=-dc_norm(1,i+1)
2071             uzder(1,3,1)=-dc_norm(2,i+1)
2072             uzder(2,3,1)= dc_norm(1,i+1)
2073             uzder(3,3,1)= 0.0d0
2074             uzder(1,1,2)= 0.0d0
2075             uzder(2,1,2)= dc_norm(3,i)
2076             uzder(3,1,2)=-dc_norm(2,i)
2077             uzder(1,2,2)=-dc_norm(3,i)
2078             uzder(2,2,2)= 0.0d0
2079             uzder(3,2,2)= dc_norm(1,i)
2080             uzder(1,3,2)= dc_norm(2,i)
2081             uzder(2,3,2)=-dc_norm(1,i)
2082             uzder(3,3,2)= 0.0d0
2083 C Compute the Y-axis
2084             facy=fac
2085             do k=1,3
2086               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2087             enddo
2088 C Compute the derivatives of uy
2089             do j=1,3
2090               do k=1,3
2091                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2092      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2093                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2094               enddo
2095               uyder(j,j,1)=uyder(j,j,1)-costh
2096               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2097             enddo
2098             do j=1,2
2099               do k=1,3
2100                 do l=1,3
2101                   uygrad(l,k,j,i)=uyder(l,k,j)
2102                   uzgrad(l,k,j,i)=uzder(l,k,j)
2103                 enddo
2104               enddo
2105             enddo
2106             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2107             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2108             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2109             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2110           endif
2111       enddo
2112       do i=1,nres-1
2113         vbld_inv_temp(1)=vbld_inv(i+1)
2114         if (i.lt.nres-1) then
2115           vbld_inv_temp(2)=vbld_inv(i+2)
2116           else
2117           vbld_inv_temp(2)=vbld_inv(i)
2118           endif
2119         do j=1,2
2120           do k=1,3
2121             do l=1,3
2122               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2123               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2124             enddo
2125           enddo
2126         enddo
2127       enddo
2128 #if defined(PARVEC) && defined(MPI)
2129       if (nfgtasks1.gt.1) then
2130         time00=MPI_Wtime()
2131 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2132 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2133 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2134         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2135      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2136      &   FG_COMM1,IERR)
2137         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2138      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2139      &   FG_COMM1,IERR)
2140         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2141      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2142      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2143         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2144      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2145      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2146         time_gather=time_gather+MPI_Wtime()-time00
2147       endif
2148 c      if (fg_rank.eq.0) then
2149 c        write (iout,*) "Arrays UY and UZ"
2150 c        do i=1,nres-1
2151 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2152 c     &     (uz(k,i),k=1,3)
2153 c        enddo
2154 c      endif
2155 #endif
2156       return
2157       end
2158 C-----------------------------------------------------------------------------
2159       subroutine check_vecgrad
2160       implicit real*8 (a-h,o-z)
2161       include 'DIMENSIONS'
2162       include 'COMMON.IOUNITS'
2163       include 'COMMON.GEO'
2164       include 'COMMON.VAR'
2165       include 'COMMON.LOCAL'
2166       include 'COMMON.CHAIN'
2167       include 'COMMON.VECTORS'
2168       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2169       dimension uyt(3,maxres),uzt(3,maxres)
2170       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2171       double precision delta /1.0d-7/
2172       call vec_and_deriv
2173 cd      do i=1,nres
2174 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2175 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2176 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2177 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2178 cd     &     (dc_norm(if90,i),if90=1,3)
2179 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2180 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2181 cd          write(iout,'(a)')
2182 cd      enddo
2183       do i=1,nres
2184         do j=1,2
2185           do k=1,3
2186             do l=1,3
2187               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2188               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2189             enddo
2190           enddo
2191         enddo
2192       enddo
2193       call vec_and_deriv
2194       do i=1,nres
2195         do j=1,3
2196           uyt(j,i)=uy(j,i)
2197           uzt(j,i)=uz(j,i)
2198         enddo
2199       enddo
2200       do i=1,nres
2201 cd        write (iout,*) 'i=',i
2202         do k=1,3
2203           erij(k)=dc_norm(k,i)
2204         enddo
2205         do j=1,3
2206           do k=1,3
2207             dc_norm(k,i)=erij(k)
2208           enddo
2209           dc_norm(j,i)=dc_norm(j,i)+delta
2210 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2211 c          do k=1,3
2212 c            dc_norm(k,i)=dc_norm(k,i)/fac
2213 c          enddo
2214 c          write (iout,*) (dc_norm(k,i),k=1,3)
2215 c          write (iout,*) (erij(k),k=1,3)
2216           call vec_and_deriv
2217           do k=1,3
2218             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2219             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2220             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2221             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2222           enddo
2223 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2224 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2225 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2226         enddo
2227         do k=1,3
2228           dc_norm(k,i)=erij(k)
2229         enddo
2230 cd        do k=1,3
2231 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2232 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2233 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2234 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2235 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2236 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2237 cd          write (iout,'(a)')
2238 cd        enddo
2239       enddo
2240       return
2241       end
2242 C--------------------------------------------------------------------------
2243       subroutine set_matrices
2244       implicit real*8 (a-h,o-z)
2245       include 'DIMENSIONS'
2246 #ifdef MPI
2247       include "mpif.h"
2248       include "COMMON.SETUP"
2249       integer IERR
2250       integer status(MPI_STATUS_SIZE)
2251 #endif
2252       include 'COMMON.IOUNITS'
2253       include 'COMMON.GEO'
2254       include 'COMMON.VAR'
2255       include 'COMMON.LOCAL'
2256       include 'COMMON.CHAIN'
2257       include 'COMMON.DERIV'
2258       include 'COMMON.INTERACT'
2259       include 'COMMON.CONTACTS'
2260       include 'COMMON.TORSION'
2261       include 'COMMON.VECTORS'
2262       include 'COMMON.FFIELD'
2263       double precision auxvec(2),auxmat(2,2)
2264 C
2265 C Compute the virtual-bond-torsional-angle dependent quantities needed
2266 C to calculate the el-loc multibody terms of various order.
2267 C
2268 #ifdef PARMAT
2269       do i=ivec_start+2,ivec_end+2
2270 #else
2271       do i=3,nres+1
2272 #endif
2273         if (i .lt. nres+1) then
2274           sin1=dsin(phi(i))
2275           cos1=dcos(phi(i))
2276           sintab(i-2)=sin1
2277           costab(i-2)=cos1
2278           obrot(1,i-2)=cos1
2279           obrot(2,i-2)=sin1
2280           sin2=dsin(2*phi(i))
2281           cos2=dcos(2*phi(i))
2282           sintab2(i-2)=sin2
2283           costab2(i-2)=cos2
2284           obrot2(1,i-2)=cos2
2285           obrot2(2,i-2)=sin2
2286           Ug(1,1,i-2)=-cos1
2287           Ug(1,2,i-2)=-sin1
2288           Ug(2,1,i-2)=-sin1
2289           Ug(2,2,i-2)= cos1
2290           Ug2(1,1,i-2)=-cos2
2291           Ug2(1,2,i-2)=-sin2
2292           Ug2(2,1,i-2)=-sin2
2293           Ug2(2,2,i-2)= cos2
2294         else
2295           costab(i-2)=1.0d0
2296           sintab(i-2)=0.0d0
2297           obrot(1,i-2)=1.0d0
2298           obrot(2,i-2)=0.0d0
2299           obrot2(1,i-2)=0.0d0
2300           obrot2(2,i-2)=0.0d0
2301           Ug(1,1,i-2)=1.0d0
2302           Ug(1,2,i-2)=0.0d0
2303           Ug(2,1,i-2)=0.0d0
2304           Ug(2,2,i-2)=1.0d0
2305           Ug2(1,1,i-2)=0.0d0
2306           Ug2(1,2,i-2)=0.0d0
2307           Ug2(2,1,i-2)=0.0d0
2308           Ug2(2,2,i-2)=0.0d0
2309         endif
2310         if (i .gt. 3 .and. i .lt. nres+1) then
2311           obrot_der(1,i-2)=-sin1
2312           obrot_der(2,i-2)= cos1
2313           Ugder(1,1,i-2)= sin1
2314           Ugder(1,2,i-2)=-cos1
2315           Ugder(2,1,i-2)=-cos1
2316           Ugder(2,2,i-2)=-sin1
2317           dwacos2=cos2+cos2
2318           dwasin2=sin2+sin2
2319           obrot2_der(1,i-2)=-dwasin2
2320           obrot2_der(2,i-2)= dwacos2
2321           Ug2der(1,1,i-2)= dwasin2
2322           Ug2der(1,2,i-2)=-dwacos2
2323           Ug2der(2,1,i-2)=-dwacos2
2324           Ug2der(2,2,i-2)=-dwasin2
2325         else
2326           obrot_der(1,i-2)=0.0d0
2327           obrot_der(2,i-2)=0.0d0
2328           Ugder(1,1,i-2)=0.0d0
2329           Ugder(1,2,i-2)=0.0d0
2330           Ugder(2,1,i-2)=0.0d0
2331           Ugder(2,2,i-2)=0.0d0
2332           obrot2_der(1,i-2)=0.0d0
2333           obrot2_der(2,i-2)=0.0d0
2334           Ug2der(1,1,i-2)=0.0d0
2335           Ug2der(1,2,i-2)=0.0d0
2336           Ug2der(2,1,i-2)=0.0d0
2337           Ug2der(2,2,i-2)=0.0d0
2338         endif
2339 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2340         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2341           iti = itortyp(itype(i-2))
2342         else
2343           iti=ntortyp+1
2344         endif
2345 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2346         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2347           iti1 = itortyp(itype(i-1))
2348         else
2349           iti1=ntortyp+1
2350         endif
2351 cd        write (iout,*) '*******i',i,' iti1',iti
2352 cd        write (iout,*) 'b1',b1(:,iti)
2353 cd        write (iout,*) 'b2',b2(:,iti)
2354 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2355 c        if (i .gt. iatel_s+2) then
2356         if (i .gt. nnt+2) then
2357           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2358           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2359           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2360      &    then
2361           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2362           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2363           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2364           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2365           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2366           endif
2367         else
2368           do k=1,2
2369             Ub2(k,i-2)=0.0d0
2370             Ctobr(k,i-2)=0.0d0
2371             Dtobr2(k,i-2)=0.0d0
2372             do l=1,2
2373               EUg(l,k,i-2)=0.0d0
2374               CUg(l,k,i-2)=0.0d0
2375               DUg(l,k,i-2)=0.0d0
2376               DtUg2(l,k,i-2)=0.0d0
2377             enddo
2378           enddo
2379         endif
2380         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2381         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2382         do k=1,2
2383           muder(k,i-2)=Ub2der(k,i-2)
2384         enddo
2385 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2386         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2387           iti1 = itortyp(itype(i-1))
2388         else
2389           iti1=ntortyp+1
2390         endif
2391         do k=1,2
2392           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2393         enddo
2394 cd        write (iout,*) 'mu ',mu(:,i-2)
2395 cd        write (iout,*) 'mu1',mu1(:,i-2)
2396 cd        write (iout,*) 'mu2',mu2(:,i-2)
2397         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2398      &  then
2399         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2400         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2401         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2402         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2403         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2404 C Vectors and matrices dependent on a single virtual-bond dihedral.
2405         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2406         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2407         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2408         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2409         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2410         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2411         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2412         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2413         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2414         endif
2415       enddo
2416 C Matrices dependent on two consecutive virtual-bond dihedrals.
2417 C The order of matrices is from left to right.
2418       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2419      &then
2420 c      do i=max0(ivec_start,2),ivec_end
2421       do i=2,nres-1
2422         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2423         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2424         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2425         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2426         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2427         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2428         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2429         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2430       enddo
2431       endif
2432 #if defined(MPI) && defined(PARMAT)
2433 #ifdef DEBUG
2434 c      if (fg_rank.eq.0) then
2435         write (iout,*) "Arrays UG and UGDER before GATHER"
2436         do i=1,nres-1
2437           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2438      &     ((ug(l,k,i),l=1,2),k=1,2),
2439      &     ((ugder(l,k,i),l=1,2),k=1,2)
2440         enddo
2441         write (iout,*) "Arrays UG2 and UG2DER"
2442         do i=1,nres-1
2443           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2444      &     ((ug2(l,k,i),l=1,2),k=1,2),
2445      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2446         enddo
2447         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2448         do i=1,nres-1
2449           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2450      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2451      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2452         enddo
2453         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2454         do i=1,nres-1
2455           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2456      &     costab(i),sintab(i),costab2(i),sintab2(i)
2457         enddo
2458         write (iout,*) "Array MUDER"
2459         do i=1,nres-1
2460           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2461         enddo
2462 c      endif
2463 #endif
2464       if (nfgtasks.gt.1) then
2465         time00=MPI_Wtime()
2466 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2467 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2468 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2469 #ifdef MATGATHER
2470         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2471      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2472      &   FG_COMM1,IERR)
2473         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2474      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2475      &   FG_COMM1,IERR)
2476         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2477      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2478      &   FG_COMM1,IERR)
2479         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2480      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2481      &   FG_COMM1,IERR)
2482         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2483      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2484      &   FG_COMM1,IERR)
2485         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2486      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2487      &   FG_COMM1,IERR)
2488         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2489      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2490      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2491         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2492      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2493      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2494         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2495      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2496      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2497         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2498      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2499      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2500         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2501      &  then
2502         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2503      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2504      &   FG_COMM1,IERR)
2505         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2506      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2507      &   FG_COMM1,IERR)
2508         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2509      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2510      &   FG_COMM1,IERR)
2511        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2512      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2513      &   FG_COMM1,IERR)
2514         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2515      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2516      &   FG_COMM1,IERR)
2517         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2518      &   ivec_count(fg_rank1),
2519      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2529      &   FG_COMM1,IERR)
2530         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2534      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2535      &   FG_COMM1,IERR)
2536         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2543      &   ivec_count(fg_rank1),
2544      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2547      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2548      &   FG_COMM1,IERR)
2549        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2550      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2551      &   FG_COMM1,IERR)
2552         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2554      &   FG_COMM1,IERR)
2555        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2559      &   ivec_count(fg_rank1),
2560      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2563      &   ivec_count(fg_rank1),
2564      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2567      &   ivec_count(fg_rank1),
2568      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2569      &   MPI_MAT2,FG_COMM1,IERR)
2570         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2571      &   ivec_count(fg_rank1),
2572      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2573      &   MPI_MAT2,FG_COMM1,IERR)
2574         endif
2575 #else
2576 c Passes matrix info through the ring
2577       isend=fg_rank1
2578       irecv=fg_rank1-1
2579       if (irecv.lt.0) irecv=nfgtasks1-1
2580       iprev=irecv
2581       inext=fg_rank1+1
2582       if (inext.ge.nfgtasks1) inext=0
2583       do i=1,nfgtasks1-1
2584 c        write (iout,*) "isend",isend," irecv",irecv
2585 c        call flush(iout)
2586         lensend=lentyp(isend)
2587         lenrecv=lentyp(irecv)
2588 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2589 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2590 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2591 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2592 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2593 c        write (iout,*) "Gather ROTAT1"
2594 c        call flush(iout)
2595 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2596 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2597 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2598 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2599 c        write (iout,*) "Gather ROTAT2"
2600 c        call flush(iout)
2601         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2602      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2603      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2604      &   iprev,4400+irecv,FG_COMM,status,IERR)
2605 c        write (iout,*) "Gather ROTAT_OLD"
2606 c        call flush(iout)
2607         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2608      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2609      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2610      &   iprev,5500+irecv,FG_COMM,status,IERR)
2611 c        write (iout,*) "Gather PRECOMP11"
2612 c        call flush(iout)
2613         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2614      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2615      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2616      &   iprev,6600+irecv,FG_COMM,status,IERR)
2617 c        write (iout,*) "Gather PRECOMP12"
2618 c        call flush(iout)
2619         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2620      &  then
2621         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2622      &   MPI_ROTAT2(lensend),inext,7700+isend,
2623      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2624      &   iprev,7700+irecv,FG_COMM,status,IERR)
2625 c        write (iout,*) "Gather PRECOMP21"
2626 c        call flush(iout)
2627         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2628      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2629      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2630      &   iprev,8800+irecv,FG_COMM,status,IERR)
2631 c        write (iout,*) "Gather PRECOMP22"
2632 c        call flush(iout)
2633         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2634      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2635      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2636      &   MPI_PRECOMP23(lenrecv),
2637      &   iprev,9900+irecv,FG_COMM,status,IERR)
2638 c        write (iout,*) "Gather PRECOMP23"
2639 c        call flush(iout)
2640         endif
2641         isend=irecv
2642         irecv=irecv-1
2643         if (irecv.lt.0) irecv=nfgtasks1-1
2644       enddo
2645 #endif
2646         time_gather=time_gather+MPI_Wtime()-time00
2647       endif
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679 #endif
2680 cd      do i=1,nres
2681 cd        iti = itortyp(itype(i))
2682 cd        write (iout,*) i
2683 cd        do j=1,2
2684 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2685 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2686 cd        enddo
2687 cd      enddo
2688       return
2689       end
2690 C--------------------------------------------------------------------------
2691       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2692 C
2693 C This subroutine calculates the average interaction energy and its gradient
2694 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2695 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2696 C The potential depends both on the distance of peptide-group centers and on
2697 C the orientation of the CA-CA virtual bonds.
2698 C
2699       implicit real*8 (a-h,o-z)
2700 #ifdef MPI
2701       include 'mpif.h'
2702 #endif
2703       include 'DIMENSIONS'
2704       include 'COMMON.CONTROL'
2705       include 'COMMON.SETUP'
2706       include 'COMMON.IOUNITS'
2707       include 'COMMON.GEO'
2708       include 'COMMON.VAR'
2709       include 'COMMON.LOCAL'
2710       include 'COMMON.CHAIN'
2711       include 'COMMON.DERIV'
2712       include 'COMMON.INTERACT'
2713       include 'COMMON.CONTACTS'
2714       include 'COMMON.TORSION'
2715       include 'COMMON.VECTORS'
2716       include 'COMMON.FFIELD'
2717       include 'COMMON.TIME1'
2718       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2719      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2720       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2721      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2722       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2723      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2724      &    num_conti,j1,j2
2725 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2726 #ifdef MOMENT
2727       double precision scal_el /1.0d0/
2728 #else
2729       double precision scal_el /0.5d0/
2730 #endif
2731 C 12/13/98
2732 C 13-go grudnia roku pamietnego...
2733       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2734      &                   0.0d0,1.0d0,0.0d0,
2735      &                   0.0d0,0.0d0,1.0d0/
2736 cd      write(iout,*) 'In EELEC'
2737 cd      do i=1,nloctyp
2738 cd        write(iout,*) 'Type',i
2739 cd        write(iout,*) 'B1',B1(:,i)
2740 cd        write(iout,*) 'B2',B2(:,i)
2741 cd        write(iout,*) 'CC',CC(:,:,i)
2742 cd        write(iout,*) 'DD',DD(:,:,i)
2743 cd        write(iout,*) 'EE',EE(:,:,i)
2744 cd      enddo
2745 cd      call check_vecgrad
2746 cd      stop
2747       if (icheckgrad.eq.1) then
2748         do i=1,nres-1
2749           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2750           do k=1,3
2751             dc_norm(k,i)=dc(k,i)*fac
2752           enddo
2753 c          write (iout,*) 'i',i,' fac',fac
2754         enddo
2755       endif
2756       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2757      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2758      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2759 c        call vec_and_deriv
2760 #ifdef TIMING
2761         time01=MPI_Wtime()
2762 #endif
2763         call set_matrices
2764 #ifdef TIMING
2765         time_mat=time_mat+MPI_Wtime()-time01
2766 #endif
2767       endif
2768 cd      do i=1,nres-1
2769 cd        write (iout,*) 'i=',i
2770 cd        do k=1,3
2771 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2772 cd        enddo
2773 cd        do k=1,3
2774 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2775 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2776 cd        enddo
2777 cd      enddo
2778       t_eelecij=0.0d0
2779       ees=0.0D0
2780       evdw1=0.0D0
2781       eel_loc=0.0d0
2782       eello_turn3=0.0d0
2783       eello_turn4=0.0d0
2784       ind=0
2785       do i=1,nres
2786         num_cont_hb(i)=0
2787       enddo
2788 cd      print '(a)','Enter EELEC'
2789 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2790       do i=1,nres
2791         gel_loc_loc(i)=0.0d0
2792         gcorr_loc(i)=0.0d0
2793       enddo
2794 c
2795 c
2796 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2797 C
2798 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2799 C
2800       do i=iturn3_start,iturn3_end
2801         if (itype(i).eq.21 .or. itype(i+1).eq.21
2802      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2803         dxi=dc(1,i)
2804         dyi=dc(2,i)
2805         dzi=dc(3,i)
2806         dx_normi=dc_norm(1,i)
2807         dy_normi=dc_norm(2,i)
2808         dz_normi=dc_norm(3,i)
2809         xmedi=c(1,i)+0.5d0*dxi
2810         ymedi=c(2,i)+0.5d0*dyi
2811         zmedi=c(3,i)+0.5d0*dzi
2812         num_conti=0
2813         call eelecij(i,i+2,ees,evdw1,eel_loc)
2814         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2815         num_cont_hb(i)=num_conti
2816       enddo
2817       do i=iturn4_start,iturn4_end
2818         if (itype(i).eq.21 .or. itype(i+1).eq.21
2819      &    .or. itype(i+3).eq.21
2820      &    .or. itype(i+4).eq.21) cycle
2821         dxi=dc(1,i)
2822         dyi=dc(2,i)
2823         dzi=dc(3,i)
2824         dx_normi=dc_norm(1,i)
2825         dy_normi=dc_norm(2,i)
2826         dz_normi=dc_norm(3,i)
2827         xmedi=c(1,i)+0.5d0*dxi
2828         ymedi=c(2,i)+0.5d0*dyi
2829         zmedi=c(3,i)+0.5d0*dzi
2830         num_conti=num_cont_hb(i)
2831         call eelecij(i,i+3,ees,evdw1,eel_loc)
2832         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2833      &   call eturn4(i,eello_turn4)
2834         num_cont_hb(i)=num_conti
2835       enddo   ! i
2836 c
2837 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2838 c
2839       do i=iatel_s,iatel_e
2840         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2841         dxi=dc(1,i)
2842         dyi=dc(2,i)
2843         dzi=dc(3,i)
2844         dx_normi=dc_norm(1,i)
2845         dy_normi=dc_norm(2,i)
2846         dz_normi=dc_norm(3,i)
2847         xmedi=c(1,i)+0.5d0*dxi
2848         ymedi=c(2,i)+0.5d0*dyi
2849         zmedi=c(3,i)+0.5d0*dzi
2850 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2851         num_conti=num_cont_hb(i)
2852         do j=ielstart(i),ielend(i)
2853 c          write (iout,*) i,j,itype(i),itype(j)
2854           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2855           call eelecij(i,j,ees,evdw1,eel_loc)
2856         enddo ! j
2857         num_cont_hb(i)=num_conti
2858       enddo   ! i
2859 c      write (iout,*) "Number of loop steps in EELEC:",ind
2860 cd      do i=1,nres
2861 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2862 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2863 cd      enddo
2864 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2865 ccc      eel_loc=eel_loc+eello_turn3
2866 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2867       return
2868       end
2869 C-------------------------------------------------------------------------------
2870       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873 #ifdef MPI
2874       include "mpif.h"
2875 #endif
2876       include 'COMMON.CONTROL'
2877       include 'COMMON.IOUNITS'
2878       include 'COMMON.GEO'
2879       include 'COMMON.VAR'
2880       include 'COMMON.LOCAL'
2881       include 'COMMON.CHAIN'
2882       include 'COMMON.DERIV'
2883       include 'COMMON.INTERACT'
2884       include 'COMMON.CONTACTS'
2885       include 'COMMON.TORSION'
2886       include 'COMMON.VECTORS'
2887       include 'COMMON.FFIELD'
2888       include 'COMMON.TIME1'
2889       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2890      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2891       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2892      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2893       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2894      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2895      &    num_conti,j1,j2
2896 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2897 #ifdef MOMENT
2898       double precision scal_el /1.0d0/
2899 #else
2900       double precision scal_el /0.5d0/
2901 #endif
2902 C 12/13/98
2903 C 13-go grudnia roku pamietnego...
2904       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2905      &                   0.0d0,1.0d0,0.0d0,
2906      &                   0.0d0,0.0d0,1.0d0/
2907 c          time00=MPI_Wtime()
2908 cd      write (iout,*) "eelecij",i,j
2909 c          ind=ind+1
2910           iteli=itel(i)
2911           itelj=itel(j)
2912           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2913           aaa=app(iteli,itelj)
2914           bbb=bpp(iteli,itelj)
2915           ael6i=ael6(iteli,itelj)
2916           ael3i=ael3(iteli,itelj)
2917           dxj=dc(1,j)
2918           dyj=dc(2,j)
2919           dzj=dc(3,j)
2920           dx_normj=dc_norm(1,j)
2921           dy_normj=dc_norm(2,j)
2922           dz_normj=dc_norm(3,j)
2923           xj=c(1,j)+0.5D0*dxj-xmedi
2924           yj=c(2,j)+0.5D0*dyj-ymedi
2925           zj=c(3,j)+0.5D0*dzj-zmedi
2926           rij=xj*xj+yj*yj+zj*zj
2927           rrmij=1.0D0/rij
2928           rij=dsqrt(rij)
2929           rmij=1.0D0/rij
2930           r3ij=rrmij*rmij
2931           r6ij=r3ij*r3ij
2932           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2933           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2934           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2935           fac=cosa-3.0D0*cosb*cosg
2936           ev1=aaa*r6ij*r6ij
2937 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2938           if (j.eq.i+2) ev1=scal_el*ev1
2939           ev2=bbb*r6ij
2940           fac3=ael6i*r6ij
2941           fac4=ael3i*r3ij
2942           evdwij=ev1+ev2
2943           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2944           el2=fac4*fac
2945           eesij=el1+el2
2946 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2947           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2948           ees=ees+eesij
2949           evdw1=evdw1+evdwij
2950 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2951 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2952 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2953 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2954
2955           if (energy_dec) then
2956               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2957               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2958           endif
2959
2960 C
2961 C Calculate contributions to the Cartesian gradient.
2962 C
2963 #ifdef SPLITELE
2964           facvdw=-6*rrmij*(ev1+evdwij)
2965           facel=-3*rrmij*(el1+eesij)
2966           fac1=fac
2967           erij(1)=xj*rmij
2968           erij(2)=yj*rmij
2969           erij(3)=zj*rmij
2970 *
2971 * Radial derivatives. First process both termini of the fragment (i,j)
2972 *
2973           ggg(1)=facel*xj
2974           ggg(2)=facel*yj
2975           ggg(3)=facel*zj
2976 c          do k=1,3
2977 c            ghalf=0.5D0*ggg(k)
2978 c            gelc(k,i)=gelc(k,i)+ghalf
2979 c            gelc(k,j)=gelc(k,j)+ghalf
2980 c          enddo
2981 c 9/28/08 AL Gradient compotents will be summed only at the end
2982           do k=1,3
2983             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2984             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2985           enddo
2986 *
2987 * Loop over residues i+1 thru j-1.
2988 *
2989 cgrad          do k=i+1,j-1
2990 cgrad            do l=1,3
2991 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2992 cgrad            enddo
2993 cgrad          enddo
2994           ggg(1)=facvdw*xj
2995           ggg(2)=facvdw*yj
2996           ggg(3)=facvdw*zj
2997 c          do k=1,3
2998 c            ghalf=0.5D0*ggg(k)
2999 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3000 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3001 c          enddo
3002 c 9/28/08 AL Gradient compotents will be summed only at the end
3003           do k=1,3
3004             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3005             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3006           enddo
3007 *
3008 * Loop over residues i+1 thru j-1.
3009 *
3010 cgrad          do k=i+1,j-1
3011 cgrad            do l=1,3
3012 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3013 cgrad            enddo
3014 cgrad          enddo
3015 #else
3016           facvdw=ev1+evdwij
3017           facel=el1+eesij
3018           fac1=fac
3019           fac=-3*rrmij*(facvdw+facvdw+facel)
3020           erij(1)=xj*rmij
3021           erij(2)=yj*rmij
3022           erij(3)=zj*rmij
3023 *
3024 * Radial derivatives. First process both termini of the fragment (i,j)
3025 *
3026           ggg(1)=fac*xj
3027           ggg(2)=fac*yj
3028           ggg(3)=fac*zj
3029 c          do k=1,3
3030 c            ghalf=0.5D0*ggg(k)
3031 c            gelc(k,i)=gelc(k,i)+ghalf
3032 c            gelc(k,j)=gelc(k,j)+ghalf
3033 c          enddo
3034 c 9/28/08 AL Gradient compotents will be summed only at the end
3035           do k=1,3
3036             gelc_long(k,j)=gelc(k,j)+ggg(k)
3037             gelc_long(k,i)=gelc(k,i)-ggg(k)
3038           enddo
3039 *
3040 * Loop over residues i+1 thru j-1.
3041 *
3042 cgrad          do k=i+1,j-1
3043 cgrad            do l=1,3
3044 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3045 cgrad            enddo
3046 cgrad          enddo
3047 c 9/28/08 AL Gradient compotents will be summed only at the end
3048           ggg(1)=facvdw*xj
3049           ggg(2)=facvdw*yj
3050           ggg(3)=facvdw*zj
3051           do k=1,3
3052             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3053             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3054           enddo
3055 #endif
3056 *
3057 * Angular part
3058 *
3059           ecosa=2.0D0*fac3*fac1+fac4
3060           fac4=-3.0D0*fac4
3061           fac3=-6.0D0*fac3
3062           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3063           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3064           do k=1,3
3065             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3066             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3067           enddo
3068 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3069 cd   &          (dcosg(k),k=1,3)
3070           do k=1,3
3071             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3072           enddo
3073 c          do k=1,3
3074 c            ghalf=0.5D0*ggg(k)
3075 c            gelc(k,i)=gelc(k,i)+ghalf
3076 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3077 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3078 c            gelc(k,j)=gelc(k,j)+ghalf
3079 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3080 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3081 c          enddo
3082 cgrad          do k=i+1,j-1
3083 cgrad            do l=1,3
3084 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3085 cgrad            enddo
3086 cgrad          enddo
3087           do k=1,3
3088             gelc(k,i)=gelc(k,i)
3089      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3090      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3091             gelc(k,j)=gelc(k,j)
3092      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3093      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3094             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3095             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3096           enddo
3097           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3098      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3099      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3100 C
3101 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3102 C   energy of a peptide unit is assumed in the form of a second-order
3103 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3104 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3105 C   are computed for EVERY pair of non-contiguous peptide groups.
3106 C
3107           if (j.lt.nres-1) then
3108             j1=j+1
3109             j2=j-1
3110           else
3111             j1=j-1
3112             j2=j-2
3113           endif
3114           kkk=0
3115           do k=1,2
3116             do l=1,2
3117               kkk=kkk+1
3118               muij(kkk)=mu(k,i)*mu(l,j)
3119             enddo
3120           enddo
3121 cd         write (iout,*) 'EELEC: i',i,' j',j
3122 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3123 cd          write(iout,*) 'muij',muij
3124           ury=scalar(uy(1,i),erij)
3125           urz=scalar(uz(1,i),erij)
3126           vry=scalar(uy(1,j),erij)
3127           vrz=scalar(uz(1,j),erij)
3128           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3129           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3130           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3131           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3132           fac=dsqrt(-ael6i)*r3ij
3133           a22=a22*fac
3134           a23=a23*fac
3135           a32=a32*fac
3136           a33=a33*fac
3137 cd          write (iout,'(4i5,4f10.5)')
3138 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3139 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3140 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3141 cd     &      uy(:,j),uz(:,j)
3142 cd          write (iout,'(4f10.5)')
3143 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3144 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3145 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3146 cd           write (iout,'(9f10.5/)')
3147 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3148 C Derivatives of the elements of A in virtual-bond vectors
3149           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3150           do k=1,3
3151             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3152             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3153             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3154             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3155             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3156             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3157             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3158             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3159             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3160             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3161             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3162             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3163           enddo
3164 C Compute radial contributions to the gradient
3165           facr=-3.0d0*rrmij
3166           a22der=a22*facr
3167           a23der=a23*facr
3168           a32der=a32*facr
3169           a33der=a33*facr
3170           agg(1,1)=a22der*xj
3171           agg(2,1)=a22der*yj
3172           agg(3,1)=a22der*zj
3173           agg(1,2)=a23der*xj
3174           agg(2,2)=a23der*yj
3175           agg(3,2)=a23der*zj
3176           agg(1,3)=a32der*xj
3177           agg(2,3)=a32der*yj
3178           agg(3,3)=a32der*zj
3179           agg(1,4)=a33der*xj
3180           agg(2,4)=a33der*yj
3181           agg(3,4)=a33der*zj
3182 C Add the contributions coming from er
3183           fac3=-3.0d0*fac
3184           do k=1,3
3185             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3186             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3187             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3188             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3189           enddo
3190           do k=1,3
3191 C Derivatives in DC(i)
3192 cgrad            ghalf1=0.5d0*agg(k,1)
3193 cgrad            ghalf2=0.5d0*agg(k,2)
3194 cgrad            ghalf3=0.5d0*agg(k,3)
3195 cgrad            ghalf4=0.5d0*agg(k,4)
3196             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3197      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3198             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3199      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3200             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3201      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3202             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3203      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3204 C Derivatives in DC(i+1)
3205             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3206      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3207             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3208      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3209             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3210      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3211             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3212      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3213 C Derivatives in DC(j)
3214             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3215      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3216             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3217      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3218             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3219      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3220             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3221      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3222 C Derivatives in DC(j+1) or DC(nres-1)
3223             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3224      &      -3.0d0*vryg(k,3)*ury)
3225             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3226      &      -3.0d0*vrzg(k,3)*ury)
3227             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3228      &      -3.0d0*vryg(k,3)*urz)
3229             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3230      &      -3.0d0*vrzg(k,3)*urz)
3231 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3232 cgrad              do l=1,4
3233 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3234 cgrad              enddo
3235 cgrad            endif
3236           enddo
3237           acipa(1,1)=a22
3238           acipa(1,2)=a23
3239           acipa(2,1)=a32
3240           acipa(2,2)=a33
3241           a22=-a22
3242           a23=-a23
3243           do l=1,2
3244             do k=1,3
3245               agg(k,l)=-agg(k,l)
3246               aggi(k,l)=-aggi(k,l)
3247               aggi1(k,l)=-aggi1(k,l)
3248               aggj(k,l)=-aggj(k,l)
3249               aggj1(k,l)=-aggj1(k,l)
3250             enddo
3251           enddo
3252           if (j.lt.nres-1) then
3253             a22=-a22
3254             a32=-a32
3255             do l=1,3,2
3256               do k=1,3
3257                 agg(k,l)=-agg(k,l)
3258                 aggi(k,l)=-aggi(k,l)
3259                 aggi1(k,l)=-aggi1(k,l)
3260                 aggj(k,l)=-aggj(k,l)
3261                 aggj1(k,l)=-aggj1(k,l)
3262               enddo
3263             enddo
3264           else
3265             a22=-a22
3266             a23=-a23
3267             a32=-a32
3268             a33=-a33
3269             do l=1,4
3270               do k=1,3
3271                 agg(k,l)=-agg(k,l)
3272                 aggi(k,l)=-aggi(k,l)
3273                 aggi1(k,l)=-aggi1(k,l)
3274                 aggj(k,l)=-aggj(k,l)
3275                 aggj1(k,l)=-aggj1(k,l)
3276               enddo
3277             enddo
3278           endif
3279           ENDIF ! WCORR
3280           IF (wel_loc.gt.0.0d0) THEN
3281 C Contribution to the local-electrostatic energy coming from the i-j pair
3282           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3283      &     +a33*muij(4)
3284 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3285
3286           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3287      &            'eelloc',i,j,eel_loc_ij
3288
3289           eel_loc=eel_loc+eel_loc_ij
3290 C Partial derivatives in virtual-bond dihedral angles gamma
3291           if (i.gt.1)
3292      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3293      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3294      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3295           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3296      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3297      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3298 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3299           do l=1,3
3300             ggg(l)=agg(l,1)*muij(1)+
3301      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3302             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3303             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3304 cgrad            ghalf=0.5d0*ggg(l)
3305 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3306 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3307           enddo
3308 cgrad          do k=i+1,j2
3309 cgrad            do l=1,3
3310 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3311 cgrad            enddo
3312 cgrad          enddo
3313 C Remaining derivatives of eello
3314           do l=1,3
3315             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3316      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3317             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3318      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3319             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3320      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3321             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3322      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3323           enddo
3324           ENDIF
3325 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3326 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3327           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3328      &       .and. num_conti.le.maxconts) then
3329 c            write (iout,*) i,j," entered corr"
3330 C
3331 C Calculate the contact function. The ith column of the array JCONT will
3332 C contain the numbers of atoms that make contacts with the atom I (of numbers
3333 C greater than I). The arrays FACONT and GACONT will contain the values of
3334 C the contact function and its derivative.
3335 c           r0ij=1.02D0*rpp(iteli,itelj)
3336 c           r0ij=1.11D0*rpp(iteli,itelj)
3337             r0ij=2.20D0*rpp(iteli,itelj)
3338 c           r0ij=1.55D0*rpp(iteli,itelj)
3339             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3340             if (fcont.gt.0.0D0) then
3341               num_conti=num_conti+1
3342               if (num_conti.gt.maxconts) then
3343                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3344      &                         ' will skip next contacts for this conf.'
3345               else
3346                 jcont_hb(num_conti,i)=j
3347 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3348 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3349                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3350      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3351 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3352 C  terms.
3353                 d_cont(num_conti,i)=rij
3354 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3355 C     --- Electrostatic-interaction matrix ---
3356                 a_chuj(1,1,num_conti,i)=a22
3357                 a_chuj(1,2,num_conti,i)=a23
3358                 a_chuj(2,1,num_conti,i)=a32
3359                 a_chuj(2,2,num_conti,i)=a33
3360 C     --- Gradient of rij
3361                 do kkk=1,3
3362                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3363                 enddo
3364                 kkll=0
3365                 do k=1,2
3366                   do l=1,2
3367                     kkll=kkll+1
3368                     do m=1,3
3369                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3370                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3371                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3372                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3373                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3374                     enddo
3375                   enddo
3376                 enddo
3377                 ENDIF
3378                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3379 C Calculate contact energies
3380                 cosa4=4.0D0*cosa
3381                 wij=cosa-3.0D0*cosb*cosg
3382                 cosbg1=cosb+cosg
3383                 cosbg2=cosb-cosg
3384 c               fac3=dsqrt(-ael6i)/r0ij**3
3385                 fac3=dsqrt(-ael6i)*r3ij
3386 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3387                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3388                 if (ees0tmp.gt.0) then
3389                   ees0pij=dsqrt(ees0tmp)
3390                 else
3391                   ees0pij=0
3392                 endif
3393 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3394                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3395                 if (ees0tmp.gt.0) then
3396                   ees0mij=dsqrt(ees0tmp)
3397                 else
3398                   ees0mij=0
3399                 endif
3400 c               ees0mij=0.0D0
3401                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3402                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3403 C Diagnostics. Comment out or remove after debugging!
3404 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3405 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3406 c               ees0m(num_conti,i)=0.0D0
3407 C End diagnostics.
3408 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3409 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3410 C Angular derivatives of the contact function
3411                 ees0pij1=fac3/ees0pij
3412                 ees0mij1=fac3/ees0mij
3413                 fac3p=-3.0D0*fac3*rrmij
3414                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3415                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3416 c               ees0mij1=0.0D0
3417                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3418                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3419                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3420                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3421                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3422                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3423                 ecosap=ecosa1+ecosa2
3424                 ecosbp=ecosb1+ecosb2
3425                 ecosgp=ecosg1+ecosg2
3426                 ecosam=ecosa1-ecosa2
3427                 ecosbm=ecosb1-ecosb2
3428                 ecosgm=ecosg1-ecosg2
3429 C Diagnostics
3430 c               ecosap=ecosa1
3431 c               ecosbp=ecosb1
3432 c               ecosgp=ecosg1
3433 c               ecosam=0.0D0
3434 c               ecosbm=0.0D0
3435 c               ecosgm=0.0D0
3436 C End diagnostics
3437                 facont_hb(num_conti,i)=fcont
3438                 fprimcont=fprimcont/rij
3439 cd              facont_hb(num_conti,i)=1.0D0
3440 C Following line is for diagnostics.
3441 cd              fprimcont=0.0D0
3442                 do k=1,3
3443                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3444                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3445                 enddo
3446                 do k=1,3
3447                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3448                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3449                 enddo
3450                 gggp(1)=gggp(1)+ees0pijp*xj
3451                 gggp(2)=gggp(2)+ees0pijp*yj
3452                 gggp(3)=gggp(3)+ees0pijp*zj
3453                 gggm(1)=gggm(1)+ees0mijp*xj
3454                 gggm(2)=gggm(2)+ees0mijp*yj
3455                 gggm(3)=gggm(3)+ees0mijp*zj
3456 C Derivatives due to the contact function
3457                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3458                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3459                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3460                 do k=1,3
3461 c
3462 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3463 c          following the change of gradient-summation algorithm.
3464 c
3465 cgrad                  ghalfp=0.5D0*gggp(k)
3466 cgrad                  ghalfm=0.5D0*gggm(k)
3467                   gacontp_hb1(k,num_conti,i)=!ghalfp
3468      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3469      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3470                   gacontp_hb2(k,num_conti,i)=!ghalfp
3471      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3472      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3473                   gacontp_hb3(k,num_conti,i)=gggp(k)
3474                   gacontm_hb1(k,num_conti,i)=!ghalfm
3475      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3476      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3477                   gacontm_hb2(k,num_conti,i)=!ghalfm
3478      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3479      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3480                   gacontm_hb3(k,num_conti,i)=gggm(k)
3481                 enddo
3482 C Diagnostics. Comment out or remove after debugging!
3483 cdiag           do k=1,3
3484 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3485 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3486 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3487 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3488 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3489 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3490 cdiag           enddo
3491               ENDIF ! wcorr
3492               endif  ! num_conti.le.maxconts
3493             endif  ! fcont.gt.0
3494           endif    ! j.gt.i+1
3495           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3496             do k=1,4
3497               do l=1,3
3498                 ghalf=0.5d0*agg(l,k)
3499                 aggi(l,k)=aggi(l,k)+ghalf
3500                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3501                 aggj(l,k)=aggj(l,k)+ghalf
3502               enddo
3503             enddo
3504             if (j.eq.nres-1 .and. i.lt.j-2) then
3505               do k=1,4
3506                 do l=1,3
3507                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3508                 enddo
3509               enddo
3510             endif
3511           endif
3512 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3513       return
3514       end
3515 C-----------------------------------------------------------------------------
3516       subroutine eturn3(i,eello_turn3)
3517 C Third- and fourth-order contributions from turns
3518       implicit real*8 (a-h,o-z)
3519       include 'DIMENSIONS'
3520       include 'COMMON.IOUNITS'
3521       include 'COMMON.GEO'
3522       include 'COMMON.VAR'
3523       include 'COMMON.LOCAL'
3524       include 'COMMON.CHAIN'
3525       include 'COMMON.DERIV'
3526       include 'COMMON.INTERACT'
3527       include 'COMMON.CONTACTS'
3528       include 'COMMON.TORSION'
3529       include 'COMMON.VECTORS'
3530       include 'COMMON.FFIELD'
3531       include 'COMMON.CONTROL'
3532       dimension ggg(3)
3533       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3534      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3535      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3536       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3537      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3538       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3539      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3540      &    num_conti,j1,j2
3541       j=i+2
3542 c      write (iout,*) "eturn3",i,j,j1,j2
3543       a_temp(1,1)=a22
3544       a_temp(1,2)=a23
3545       a_temp(2,1)=a32
3546       a_temp(2,2)=a33
3547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3548 C
3549 C               Third-order contributions
3550 C
3551 C                 (i+2)o----(i+3)
3552 C                      | |
3553 C                      | |
3554 C                 (i+1)o----i
3555 C
3556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3557 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3558         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3559         call transpose2(auxmat(1,1),auxmat1(1,1))
3560         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3561         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3562         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3563      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3564 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3565 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3566 cd     &    ' eello_turn3_num',4*eello_turn3_num
3567 C Derivatives in gamma(i)
3568         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3569         call transpose2(auxmat2(1,1),auxmat3(1,1))
3570         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3571         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3572 C Derivatives in gamma(i+1)
3573         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3574         call transpose2(auxmat2(1,1),auxmat3(1,1))
3575         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3576         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3577      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3578 C Cartesian derivatives
3579         do l=1,3
3580 c            ghalf1=0.5d0*agg(l,1)
3581 c            ghalf2=0.5d0*agg(l,2)
3582 c            ghalf3=0.5d0*agg(l,3)
3583 c            ghalf4=0.5d0*agg(l,4)
3584           a_temp(1,1)=aggi(l,1)!+ghalf1
3585           a_temp(1,2)=aggi(l,2)!+ghalf2
3586           a_temp(2,1)=aggi(l,3)!+ghalf3
3587           a_temp(2,2)=aggi(l,4)!+ghalf4
3588           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3589           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3590      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3591           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3592           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3593           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3594           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3595           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3596           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3597      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3598           a_temp(1,1)=aggj(l,1)!+ghalf1
3599           a_temp(1,2)=aggj(l,2)!+ghalf2
3600           a_temp(2,1)=aggj(l,3)!+ghalf3
3601           a_temp(2,2)=aggj(l,4)!+ghalf4
3602           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3603           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3604      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3605           a_temp(1,1)=aggj1(l,1)
3606           a_temp(1,2)=aggj1(l,2)
3607           a_temp(2,1)=aggj1(l,3)
3608           a_temp(2,2)=aggj1(l,4)
3609           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3610           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3611      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3612         enddo
3613       return
3614       end
3615 C-------------------------------------------------------------------------------
3616       subroutine eturn4(i,eello_turn4)
3617 C Third- and fourth-order contributions from turns
3618       implicit real*8 (a-h,o-z)
3619       include 'DIMENSIONS'
3620       include 'COMMON.IOUNITS'
3621       include 'COMMON.GEO'
3622       include 'COMMON.VAR'
3623       include 'COMMON.LOCAL'
3624       include 'COMMON.CHAIN'
3625       include 'COMMON.DERIV'
3626       include 'COMMON.INTERACT'
3627       include 'COMMON.CONTACTS'
3628       include 'COMMON.TORSION'
3629       include 'COMMON.VECTORS'
3630       include 'COMMON.FFIELD'
3631       include 'COMMON.CONTROL'
3632       dimension ggg(3)
3633       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3634      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3635      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3636       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3637      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3638       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3639      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3640      &    num_conti,j1,j2
3641       j=i+3
3642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3643 C
3644 C               Fourth-order contributions
3645 C
3646 C                 (i+3)o----(i+4)
3647 C                     /  |
3648 C               (i+2)o   |
3649 C                     \  |
3650 C                 (i+1)o----i
3651 C
3652 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3653 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3654 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3655         a_temp(1,1)=a22
3656         a_temp(1,2)=a23
3657         a_temp(2,1)=a32
3658         a_temp(2,2)=a33
3659         iti1=itortyp(itype(i+1))
3660         iti2=itortyp(itype(i+2))
3661         iti3=itortyp(itype(i+3))
3662 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3663         call transpose2(EUg(1,1,i+1),e1t(1,1))
3664         call transpose2(Eug(1,1,i+2),e2t(1,1))
3665         call transpose2(Eug(1,1,i+3),e3t(1,1))
3666         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3667         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3668         s1=scalar2(b1(1,iti2),auxvec(1))
3669         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3670         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3671         s2=scalar2(b1(1,iti1),auxvec(1))
3672         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3673         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3674         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3675         eello_turn4=eello_turn4-(s1+s2+s3)
3676         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3677      &      'eturn4',i,j,-(s1+s2+s3)
3678 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3679 cd     &    ' eello_turn4_num',8*eello_turn4_num
3680 C Derivatives in gamma(i)
3681         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3682         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3683         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3684         s1=scalar2(b1(1,iti2),auxvec(1))
3685         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3686         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3687         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3688 C Derivatives in gamma(i+1)
3689         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3690         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3691         s2=scalar2(b1(1,iti1),auxvec(1))
3692         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3693         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3694         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3695         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3696 C Derivatives in gamma(i+2)
3697         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3698         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3699         s1=scalar2(b1(1,iti2),auxvec(1))
3700         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3701         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3702         s2=scalar2(b1(1,iti1),auxvec(1))
3703         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3704         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3705         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3706         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3707 C Cartesian derivatives
3708 C Derivatives of this turn contributions in DC(i+2)
3709         if (j.lt.nres-1) then
3710           do l=1,3
3711             a_temp(1,1)=agg(l,1)
3712             a_temp(1,2)=agg(l,2)
3713             a_temp(2,1)=agg(l,3)
3714             a_temp(2,2)=agg(l,4)
3715             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3716             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3717             s1=scalar2(b1(1,iti2),auxvec(1))
3718             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3719             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3720             s2=scalar2(b1(1,iti1),auxvec(1))
3721             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3722             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3723             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724             ggg(l)=-(s1+s2+s3)
3725             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3726           enddo
3727         endif
3728 C Remaining derivatives of this turn contribution
3729         do l=1,3
3730           a_temp(1,1)=aggi(l,1)
3731           a_temp(1,2)=aggi(l,2)
3732           a_temp(2,1)=aggi(l,3)
3733           a_temp(2,2)=aggi(l,4)
3734           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3735           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3736           s1=scalar2(b1(1,iti2),auxvec(1))
3737           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3738           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3739           s2=scalar2(b1(1,iti1),auxvec(1))
3740           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3741           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3742           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3744           a_temp(1,1)=aggi1(l,1)
3745           a_temp(1,2)=aggi1(l,2)
3746           a_temp(2,1)=aggi1(l,3)
3747           a_temp(2,2)=aggi1(l,4)
3748           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3749           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3750           s1=scalar2(b1(1,iti2),auxvec(1))
3751           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3752           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3753           s2=scalar2(b1(1,iti1),auxvec(1))
3754           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3755           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3756           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3757           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3758           a_temp(1,1)=aggj(l,1)
3759           a_temp(1,2)=aggj(l,2)
3760           a_temp(2,1)=aggj(l,3)
3761           a_temp(2,2)=aggj(l,4)
3762           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3763           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3764           s1=scalar2(b1(1,iti2),auxvec(1))
3765           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3766           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3767           s2=scalar2(b1(1,iti1),auxvec(1))
3768           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3769           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3770           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3771           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3772           a_temp(1,1)=aggj1(l,1)
3773           a_temp(1,2)=aggj1(l,2)
3774           a_temp(2,1)=aggj1(l,3)
3775           a_temp(2,2)=aggj1(l,4)
3776           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3777           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3778           s1=scalar2(b1(1,iti2),auxvec(1))
3779           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3780           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3781           s2=scalar2(b1(1,iti1),auxvec(1))
3782           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3783           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3784           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3785 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3786           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3787         enddo
3788       return
3789       end
3790 C-----------------------------------------------------------------------------
3791       subroutine vecpr(u,v,w)
3792       implicit real*8(a-h,o-z)
3793       dimension u(3),v(3),w(3)
3794       w(1)=u(2)*v(3)-u(3)*v(2)
3795       w(2)=-u(1)*v(3)+u(3)*v(1)
3796       w(3)=u(1)*v(2)-u(2)*v(1)
3797       return
3798       end
3799 C-----------------------------------------------------------------------------
3800       subroutine unormderiv(u,ugrad,unorm,ungrad)
3801 C This subroutine computes the derivatives of a normalized vector u, given
3802 C the derivatives computed without normalization conditions, ugrad. Returns
3803 C ungrad.
3804       implicit none
3805       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3806       double precision vec(3)
3807       double precision scalar
3808       integer i,j
3809 c      write (2,*) 'ugrad',ugrad
3810 c      write (2,*) 'u',u
3811       do i=1,3
3812         vec(i)=scalar(ugrad(1,i),u(1))
3813       enddo
3814 c      write (2,*) 'vec',vec
3815       do i=1,3
3816         do j=1,3
3817           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3818         enddo
3819       enddo
3820 c      write (2,*) 'ungrad',ungrad
3821       return
3822       end
3823 C-----------------------------------------------------------------------------
3824       subroutine escp_soft_sphere(evdw2,evdw2_14)
3825 C
3826 C This subroutine calculates the excluded-volume interaction energy between
3827 C peptide-group centers and side chains and its gradient in virtual-bond and
3828 C side-chain vectors.
3829 C
3830       implicit real*8 (a-h,o-z)
3831       include 'DIMENSIONS'
3832       include 'COMMON.GEO'
3833       include 'COMMON.VAR'
3834       include 'COMMON.LOCAL'
3835       include 'COMMON.CHAIN'
3836       include 'COMMON.DERIV'
3837       include 'COMMON.INTERACT'
3838       include 'COMMON.FFIELD'
3839       include 'COMMON.IOUNITS'
3840       include 'COMMON.CONTROL'
3841       dimension ggg(3)
3842       evdw2=0.0D0
3843       evdw2_14=0.0d0
3844       r0_scp=4.5d0
3845 cd    print '(a)','Enter ESCP'
3846 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3847       do i=iatscp_s,iatscp_e
3848         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3849         iteli=itel(i)
3850         xi=0.5D0*(c(1,i)+c(1,i+1))
3851         yi=0.5D0*(c(2,i)+c(2,i+1))
3852         zi=0.5D0*(c(3,i)+c(3,i+1))
3853
3854         do iint=1,nscp_gr(i)
3855
3856         do j=iscpstart(i,iint),iscpend(i,iint)
3857           if (itype(j).eq.21) cycle
3858           itypj=itype(j)
3859 C Uncomment following three lines for SC-p interactions
3860 c         xj=c(1,nres+j)-xi
3861 c         yj=c(2,nres+j)-yi
3862 c         zj=c(3,nres+j)-zi
3863 C Uncomment following three lines for Ca-p interactions
3864           xj=c(1,j)-xi
3865           yj=c(2,j)-yi
3866           zj=c(3,j)-zi
3867           rij=xj*xj+yj*yj+zj*zj
3868           r0ij=r0_scp
3869           r0ijsq=r0ij*r0ij
3870           if (rij.lt.r0ijsq) then
3871             evdwij=0.25d0*(rij-r0ijsq)**2
3872             fac=rij-r0ijsq
3873           else
3874             evdwij=0.0d0
3875             fac=0.0d0
3876           endif
3877           evdw2=evdw2+evdwij
3878 C
3879 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3880 C
3881           ggg(1)=xj*fac
3882           ggg(2)=yj*fac
3883           ggg(3)=zj*fac
3884 cgrad          if (j.lt.i) then
3885 cd          write (iout,*) 'j<i'
3886 C Uncomment following three lines for SC-p interactions
3887 c           do k=1,3
3888 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3889 c           enddo
3890 cgrad          else
3891 cd          write (iout,*) 'j>i'
3892 cgrad            do k=1,3
3893 cgrad              ggg(k)=-ggg(k)
3894 C Uncomment following line for SC-p interactions
3895 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3896 cgrad            enddo
3897 cgrad          endif
3898 cgrad          do k=1,3
3899 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3900 cgrad          enddo
3901 cgrad          kstart=min0(i+1,j)
3902 cgrad          kend=max0(i-1,j-1)
3903 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3904 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3905 cgrad          do k=kstart,kend
3906 cgrad            do l=1,3
3907 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3908 cgrad            enddo
3909 cgrad          enddo
3910           do k=1,3
3911             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3912             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3913           enddo
3914         enddo
3915
3916         enddo ! iint
3917       enddo ! i
3918       return
3919       end
3920 C-----------------------------------------------------------------------------
3921       subroutine escp(evdw2,evdw2_14)
3922 C
3923 C This subroutine calculates the excluded-volume interaction energy between
3924 C peptide-group centers and side chains and its gradient in virtual-bond and
3925 C side-chain vectors.
3926 C
3927       implicit real*8 (a-h,o-z)
3928       include 'DIMENSIONS'
3929       include 'COMMON.GEO'
3930       include 'COMMON.VAR'
3931       include 'COMMON.LOCAL'
3932       include 'COMMON.CHAIN'
3933       include 'COMMON.DERIV'
3934       include 'COMMON.INTERACT'
3935       include 'COMMON.FFIELD'
3936       include 'COMMON.IOUNITS'
3937       include 'COMMON.CONTROL'
3938       dimension ggg(3)
3939       evdw2=0.0D0
3940       evdw2_14=0.0d0
3941 cd    print '(a)','Enter ESCP'
3942 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3943       do i=iatscp_s,iatscp_e
3944         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3945         iteli=itel(i)
3946         xi=0.5D0*(c(1,i)+c(1,i+1))
3947         yi=0.5D0*(c(2,i)+c(2,i+1))
3948         zi=0.5D0*(c(3,i)+c(3,i+1))
3949
3950         do iint=1,nscp_gr(i)
3951
3952         do j=iscpstart(i,iint),iscpend(i,iint)
3953           itypj=itype(j)
3954           if (itypj.eq.21) cycle
3955 C Uncomment following three lines for SC-p interactions
3956 c         xj=c(1,nres+j)-xi
3957 c         yj=c(2,nres+j)-yi
3958 c         zj=c(3,nres+j)-zi
3959 C Uncomment following three lines for Ca-p interactions
3960           xj=c(1,j)-xi
3961           yj=c(2,j)-yi
3962           zj=c(3,j)-zi
3963           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3964           fac=rrij**expon2
3965           e1=fac*fac*aad(itypj,iteli)
3966           e2=fac*bad(itypj,iteli)
3967           if (iabs(j-i) .le. 2) then
3968             e1=scal14*e1
3969             e2=scal14*e2
3970             evdw2_14=evdw2_14+e1+e2
3971           endif
3972           evdwij=e1+e2
3973           evdw2=evdw2+evdwij
3974           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3975      &        'evdw2',i,j,evdwij
3976 C
3977 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3978 C
3979           fac=-(evdwij+e1)*rrij
3980           ggg(1)=xj*fac
3981           ggg(2)=yj*fac
3982           ggg(3)=zj*fac
3983 cgrad          if (j.lt.i) then
3984 cd          write (iout,*) 'j<i'
3985 C Uncomment following three lines for SC-p interactions
3986 c           do k=1,3
3987 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3988 c           enddo
3989 cgrad          else
3990 cd          write (iout,*) 'j>i'
3991 cgrad            do k=1,3
3992 cgrad              ggg(k)=-ggg(k)
3993 C Uncomment following line for SC-p interactions
3994 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3995 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3996 cgrad            enddo
3997 cgrad          endif
3998 cgrad          do k=1,3
3999 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4000 cgrad          enddo
4001 cgrad          kstart=min0(i+1,j)
4002 cgrad          kend=max0(i-1,j-1)
4003 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4004 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4005 cgrad          do k=kstart,kend
4006 cgrad            do l=1,3
4007 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4008 cgrad            enddo
4009 cgrad          enddo
4010           do k=1,3
4011             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4012             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4013           enddo
4014         enddo
4015
4016         enddo ! iint
4017       enddo ! i
4018       do i=1,nct
4019         do j=1,3
4020           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4021           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4022           gradx_scp(j,i)=expon*gradx_scp(j,i)
4023         enddo
4024       enddo
4025 C******************************************************************************
4026 C
4027 C                              N O T E !!!
4028 C
4029 C To save time the factor EXPON has been extracted from ALL components
4030 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4031 C use!
4032 C
4033 C******************************************************************************
4034       return
4035       end
4036 C--------------------------------------------------------------------------
4037       subroutine edis(ehpb)
4038 C
4039 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4040 C
4041       implicit real*8 (a-h,o-z)
4042       include 'DIMENSIONS'
4043       include 'COMMON.SBRIDGE'
4044       include 'COMMON.CHAIN'
4045       include 'COMMON.DERIV'
4046       include 'COMMON.VAR'
4047       include 'COMMON.INTERACT'
4048       include 'COMMON.IOUNITS'
4049       dimension ggg(3)
4050       ehpb=0.0D0
4051 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4052 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4053       if (link_end.eq.0) return
4054       do i=link_start,link_end
4055 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4056 C CA-CA distance used in regularization of structure.
4057         ii=ihpb(i)
4058         jj=jhpb(i)
4059 C iii and jjj point to the residues for which the distance is assigned.
4060         if (ii.gt.nres) then
4061           iii=ii-nres
4062           jjj=jj-nres
4063         else
4064           iii=ii
4065           jjj=jj
4066         endif
4067 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4068 c     &    dhpb(i),dhpb1(i),forcon(i)
4069 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4070 C    distance and angle dependent SS bond potential.
4071 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4072 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4073         if (.not.dyn_ss .and. i.le.nss) then
4074 C 15/02/13 CC dynamic SSbond - additional check
4075          if (ii.gt.nres
4076      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4077           call ssbond_ene(iii,jjj,eij)
4078           ehpb=ehpb+2*eij
4079          endif
4080 cd          write (iout,*) "eij",eij
4081         else
4082 C Calculate the distance between the two points and its difference from the
4083 C target distance.
4084           dd=dist(ii,jj)
4085             rdis=dd-dhpb(i)
4086 C Get the force constant corresponding to this distance.
4087             waga=forcon(i)
4088 C Calculate the contribution to energy.
4089             ehpb=ehpb+waga*rdis*rdis
4090 C
4091 C Evaluate gradient.
4092 C
4093             fac=waga*rdis/dd
4094 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4095 cd   &   ' waga=',waga,' fac=',fac
4096             do j=1,3
4097               ggg(j)=fac*(c(j,jj)-c(j,ii))
4098             enddo
4099 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4100 C If this is a SC-SC distance, we need to calculate the contributions to the
4101 C Cartesian gradient in the SC vectors (ghpbx).
4102           if (iii.lt.ii) then
4103           do j=1,3
4104             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4105             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4106           enddo
4107           endif
4108 cgrad        do j=iii,jjj-1
4109 cgrad          do k=1,3
4110 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4111 cgrad          enddo
4112 cgrad        enddo
4113           do k=1,3
4114             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4115             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4116           enddo
4117         endif
4118       enddo
4119       ehpb=0.5D0*ehpb
4120       return
4121       end
4122 C--------------------------------------------------------------------------
4123       subroutine ssbond_ene(i,j,eij)
4124 C
4125 C Calculate the distance and angle dependent SS-bond potential energy
4126 C using a free-energy function derived based on RHF/6-31G** ab initio
4127 C calculations of diethyl disulfide.
4128 C
4129 C A. Liwo and U. Kozlowska, 11/24/03
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.SBRIDGE'
4134       include 'COMMON.CHAIN'
4135       include 'COMMON.DERIV'
4136       include 'COMMON.LOCAL'
4137       include 'COMMON.INTERACT'
4138       include 'COMMON.VAR'
4139       include 'COMMON.IOUNITS'
4140       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4141       itypi=itype(i)
4142       xi=c(1,nres+i)
4143       yi=c(2,nres+i)
4144       zi=c(3,nres+i)
4145       dxi=dc_norm(1,nres+i)
4146       dyi=dc_norm(2,nres+i)
4147       dzi=dc_norm(3,nres+i)
4148 c      dsci_inv=dsc_inv(itypi)
4149       dsci_inv=vbld_inv(nres+i)
4150       itypj=itype(j)
4151 c      dscj_inv=dsc_inv(itypj)
4152       dscj_inv=vbld_inv(nres+j)
4153       xj=c(1,nres+j)-xi
4154       yj=c(2,nres+j)-yi
4155       zj=c(3,nres+j)-zi
4156       dxj=dc_norm(1,nres+j)
4157       dyj=dc_norm(2,nres+j)
4158       dzj=dc_norm(3,nres+j)
4159       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4160       rij=dsqrt(rrij)
4161       erij(1)=xj*rij
4162       erij(2)=yj*rij
4163       erij(3)=zj*rij
4164       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4165       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4166       om12=dxi*dxj+dyi*dyj+dzi*dzj
4167       do k=1,3
4168         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4169         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4170       enddo
4171       rij=1.0d0/rij
4172       deltad=rij-d0cm
4173       deltat1=1.0d0-om1
4174       deltat2=1.0d0+om2
4175       deltat12=om2-om1+2.0d0
4176       cosphi=om12-om1*om2
4177       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4178      &  +akct*deltad*deltat12
4179      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4180 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4181 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4182 c     &  " deltat12",deltat12," eij",eij
4183       ed=2*akcm*deltad+akct*deltat12
4184       pom1=akct*deltad
4185       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4186       eom1=-2*akth*deltat1-pom1-om2*pom2
4187       eom2= 2*akth*deltat2+pom1-om1*pom2
4188       eom12=pom2
4189       do k=1,3
4190         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4191         ghpbx(k,i)=ghpbx(k,i)-ggk
4192      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4193      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4194         ghpbx(k,j)=ghpbx(k,j)+ggk
4195      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4196      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4197         ghpbc(k,i)=ghpbc(k,i)-ggk
4198         ghpbc(k,j)=ghpbc(k,j)+ggk
4199       enddo
4200 C
4201 C Calculate the components of the gradient in DC and X
4202 C
4203 cgrad      do k=i,j-1
4204 cgrad        do l=1,3
4205 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4206 cgrad        enddo
4207 cgrad      enddo
4208       return
4209       end
4210 C--------------------------------------------------------------------------
4211       subroutine ebond(estr)
4212 c
4213 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4214 c
4215       implicit real*8 (a-h,o-z)
4216       include 'DIMENSIONS'
4217       include 'COMMON.LOCAL'
4218       include 'COMMON.GEO'
4219       include 'COMMON.INTERACT'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.VAR'
4222       include 'COMMON.CHAIN'
4223       include 'COMMON.IOUNITS'
4224       include 'COMMON.NAMES'
4225       include 'COMMON.FFIELD'
4226       include 'COMMON.CONTROL'
4227       include 'COMMON.SETUP'
4228       double precision u(3),ud(3)
4229       estr=0.0d0
4230       estr1=0.0d0
4231       do i=ibondp_start,ibondp_end
4232         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4233           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4234           do j=1,3
4235           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4236      &      *dc(j,i-1)/vbld(i)
4237           enddo
4238           if (energy_dec) write(iout,*)
4239      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4240         else
4241         diff = vbld(i)-vbldp0
4242         if (energy_dec) write (iout,*)
4243      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4244         estr=estr+diff*diff
4245         do j=1,3
4246           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4247         enddo
4248 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4249         endif
4250       enddo
4251       estr=0.5d0*AKP*estr+estr1
4252 c
4253 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4254 c
4255       do i=ibond_start,ibond_end
4256         iti=itype(i)
4257         if (iti.ne.10 .and. iti.ne.21) then
4258           nbi=nbondterm(iti)
4259           if (nbi.eq.1) then
4260             diff=vbld(i+nres)-vbldsc0(1,iti)
4261             if (energy_dec) write (iout,*)
4262      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4263      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4264             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4265             do j=1,3
4266               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4267             enddo
4268           else
4269             do j=1,nbi
4270               diff=vbld(i+nres)-vbldsc0(j,iti)
4271               ud(j)=aksc(j,iti)*diff
4272               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4273             enddo
4274             uprod=u(1)
4275             do j=2,nbi
4276               uprod=uprod*u(j)
4277             enddo
4278             usum=0.0d0
4279             usumsqder=0.0d0
4280             do j=1,nbi
4281               uprod1=1.0d0
4282               uprod2=1.0d0
4283               do k=1,nbi
4284                 if (k.ne.j) then
4285                   uprod1=uprod1*u(k)
4286                   uprod2=uprod2*u(k)*u(k)
4287                 endif
4288               enddo
4289               usum=usum+uprod1
4290               usumsqder=usumsqder+ud(j)*uprod2
4291             enddo
4292             estr=estr+uprod/usum
4293             do j=1,3
4294              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4295             enddo
4296           endif
4297         endif
4298       enddo
4299       return
4300       end
4301 #ifdef CRYST_THETA
4302 C--------------------------------------------------------------------------
4303       subroutine ebend(etheta)
4304 C
4305 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4306 C angles gamma and its derivatives in consecutive thetas and gammas.
4307 C
4308       implicit real*8 (a-h,o-z)
4309       include 'DIMENSIONS'
4310       include 'COMMON.LOCAL'
4311       include 'COMMON.GEO'
4312       include 'COMMON.INTERACT'
4313       include 'COMMON.DERIV'
4314       include 'COMMON.VAR'
4315       include 'COMMON.CHAIN'
4316       include 'COMMON.IOUNITS'
4317       include 'COMMON.NAMES'
4318       include 'COMMON.FFIELD'
4319       include 'COMMON.CONTROL'
4320       common /calcthet/ term1,term2,termm,diffak,ratak,
4321      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4322      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4323       double precision y(2),z(2)
4324       delta=0.02d0*pi
4325 c      time11=dexp(-2*time)
4326 c      time12=1.0d0
4327       etheta=0.0D0
4328 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4329       do i=ithet_start,ithet_end
4330         if (itype(i-1).eq.21) cycle
4331 C Zero the energy function and its derivative at 0 or pi.
4332         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4333         it=itype(i-1)
4334         if (i.gt.3 .and. itype(i-2).ne.21) then
4335 #ifdef OSF
4336           phii=phi(i)
4337           if (phii.ne.phii) phii=150.0
4338 #else
4339           phii=phi(i)
4340 #endif
4341           y(1)=dcos(phii)
4342           y(2)=dsin(phii)
4343         else
4344           y(1)=0.0D0
4345           y(2)=0.0D0
4346         endif
4347         if (i.lt.nres .and. itype(i).ne.21) then
4348 #ifdef OSF
4349           phii1=phi(i+1)
4350           if (phii1.ne.phii1) phii1=150.0
4351           phii1=pinorm(phii1)
4352           z(1)=cos(phii1)
4353 #else
4354           phii1=phi(i+1)
4355           z(1)=dcos(phii1)
4356 #endif
4357           z(2)=dsin(phii1)
4358         else
4359           z(1)=0.0D0
4360           z(2)=0.0D0
4361         endif
4362 C Calculate the "mean" value of theta from the part of the distribution
4363 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4364 C In following comments this theta will be referred to as t_c.
4365         thet_pred_mean=0.0d0
4366         do k=1,2
4367           athetk=athet(k,it)
4368           bthetk=bthet(k,it)
4369           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4370         enddo
4371         dthett=thet_pred_mean*ssd
4372         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4373 C Derivatives of the "mean" values in gamma1 and gamma2.
4374         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4375         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4376         if (theta(i).gt.pi-delta) then
4377           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4378      &         E_tc0)
4379           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4380           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4381           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4382      &        E_theta)
4383           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4384      &        E_tc)
4385         else if (theta(i).lt.delta) then
4386           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4387           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4388           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4389      &        E_theta)
4390           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4391           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4392      &        E_tc)
4393         else
4394           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4395      &        E_theta,E_tc)
4396         endif
4397         etheta=etheta+ethetai
4398         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4399      &      'ebend',i,ethetai
4400         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4401         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4402         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4403       enddo
4404 C Ufff.... We've done all this!!!
4405       return
4406       end
4407 C---------------------------------------------------------------------------
4408       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4409      &     E_tc)
4410       implicit real*8 (a-h,o-z)
4411       include 'DIMENSIONS'
4412       include 'COMMON.LOCAL'
4413       include 'COMMON.IOUNITS'
4414       common /calcthet/ term1,term2,termm,diffak,ratak,
4415      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4416      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4417 C Calculate the contributions to both Gaussian lobes.
4418 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4419 C The "polynomial part" of the "standard deviation" of this part of
4420 C the distribution.
4421         sig=polthet(3,it)
4422         do j=2,0,-1
4423           sig=sig*thet_pred_mean+polthet(j,it)
4424         enddo
4425 C Derivative of the "interior part" of the "standard deviation of the"
4426 C gamma-dependent Gaussian lobe in t_c.
4427         sigtc=3*polthet(3,it)
4428         do j=2,1,-1
4429           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4430         enddo
4431         sigtc=sig*sigtc
4432 C Set the parameters of both Gaussian lobes of the distribution.
4433 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4434         fac=sig*sig+sigc0(it)
4435         sigcsq=fac+fac
4436         sigc=1.0D0/sigcsq
4437 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4438         sigsqtc=-4.0D0*sigcsq*sigtc
4439 c       print *,i,sig,sigtc,sigsqtc
4440 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4441         sigtc=-sigtc/(fac*fac)
4442 C Following variable is sigma(t_c)**(-2)
4443         sigcsq=sigcsq*sigcsq
4444         sig0i=sig0(it)
4445         sig0inv=1.0D0/sig0i**2
4446         delthec=thetai-thet_pred_mean
4447         delthe0=thetai-theta0i
4448         term1=-0.5D0*sigcsq*delthec*delthec
4449         term2=-0.5D0*sig0inv*delthe0*delthe0
4450 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4451 C NaNs in taking the logarithm. We extract the largest exponent which is added
4452 C to the energy (this being the log of the distribution) at the end of energy
4453 C term evaluation for this virtual-bond angle.
4454         if (term1.gt.term2) then
4455           termm=term1
4456           term2=dexp(term2-termm)
4457           term1=1.0d0
4458         else
4459           termm=term2
4460           term1=dexp(term1-termm)
4461           term2=1.0d0
4462         endif
4463 C The ratio between the gamma-independent and gamma-dependent lobes of
4464 C the distribution is a Gaussian function of thet_pred_mean too.
4465         diffak=gthet(2,it)-thet_pred_mean
4466         ratak=diffak/gthet(3,it)**2
4467         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4468 C Let's differentiate it in thet_pred_mean NOW.
4469         aktc=ak*ratak
4470 C Now put together the distribution terms to make complete distribution.
4471         termexp=term1+ak*term2
4472         termpre=sigc+ak*sig0i
4473 C Contribution of the bending energy from this theta is just the -log of
4474 C the sum of the contributions from the two lobes and the pre-exponential
4475 C factor. Simple enough, isn't it?
4476         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4477 C NOW the derivatives!!!
4478 C 6/6/97 Take into account the deformation.
4479         E_theta=(delthec*sigcsq*term1
4480      &       +ak*delthe0*sig0inv*term2)/termexp
4481         E_tc=((sigtc+aktc*sig0i)/termpre
4482      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4483      &       aktc*term2)/termexp)
4484       return
4485       end
4486 c-----------------------------------------------------------------------------
4487       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4488       implicit real*8 (a-h,o-z)
4489       include 'DIMENSIONS'
4490       include 'COMMON.LOCAL'
4491       include 'COMMON.IOUNITS'
4492       common /calcthet/ term1,term2,termm,diffak,ratak,
4493      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4494      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4495       delthec=thetai-thet_pred_mean
4496       delthe0=thetai-theta0i
4497 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4498       t3 = thetai-thet_pred_mean
4499       t6 = t3**2
4500       t9 = term1
4501       t12 = t3*sigcsq
4502       t14 = t12+t6*sigsqtc
4503       t16 = 1.0d0
4504       t21 = thetai-theta0i
4505       t23 = t21**2
4506       t26 = term2
4507       t27 = t21*t26
4508       t32 = termexp
4509       t40 = t32**2
4510       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4511      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4512      & *(-t12*t9-ak*sig0inv*t27)
4513       return
4514       end
4515 #else
4516 C--------------------------------------------------------------------------
4517       subroutine ebend(etheta)
4518 C
4519 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4520 C angles gamma and its derivatives in consecutive thetas and gammas.
4521 C ab initio-derived potentials from
4522 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4523 C
4524       implicit real*8 (a-h,o-z)
4525       include 'DIMENSIONS'
4526       include 'COMMON.LOCAL'
4527       include 'COMMON.GEO'
4528       include 'COMMON.INTERACT'
4529       include 'COMMON.DERIV'
4530       include 'COMMON.VAR'
4531       include 'COMMON.CHAIN'
4532       include 'COMMON.IOUNITS'
4533       include 'COMMON.NAMES'
4534       include 'COMMON.FFIELD'
4535       include 'COMMON.CONTROL'
4536       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4537      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4538      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4539      & sinph1ph2(maxdouble,maxdouble)
4540       logical lprn /.false./, lprn1 /.false./
4541       etheta=0.0D0
4542       do i=ithet_start,ithet_end
4543         if (itype(i-1).eq.21) cycle
4544         dethetai=0.0d0
4545         dephii=0.0d0
4546         dephii1=0.0d0
4547         theti2=0.5d0*theta(i)
4548         ityp2=ithetyp(itype(i-1))
4549         do k=1,nntheterm
4550           coskt(k)=dcos(k*theti2)
4551           sinkt(k)=dsin(k*theti2)
4552         enddo
4553         if (i.gt.3 .and. itype(i-2).ne.21) then
4554 #ifdef OSF
4555           phii=phi(i)
4556           if (phii.ne.phii) phii=150.0
4557 #else
4558           phii=phi(i)
4559 #endif
4560           ityp1=ithetyp(itype(i-2))
4561           do k=1,nsingle
4562             cosph1(k)=dcos(k*phii)
4563             sinph1(k)=dsin(k*phii)
4564           enddo
4565         else
4566           phii=0.0d0
4567           ityp1=nthetyp+1
4568           do k=1,nsingle
4569             cosph1(k)=0.0d0
4570             sinph1(k)=0.0d0
4571           enddo
4572         endif
4573         if (i.lt.nres .and. itype(i).ne.21) then
4574 #ifdef OSF
4575           phii1=phi(i+1)
4576           if (phii1.ne.phii1) phii1=150.0
4577           phii1=pinorm(phii1)
4578 #else
4579           phii1=phi(i+1)
4580 #endif
4581           ityp3=ithetyp(itype(i))
4582           do k=1,nsingle
4583             cosph2(k)=dcos(k*phii1)
4584             sinph2(k)=dsin(k*phii1)
4585           enddo
4586         else
4587           phii1=0.0d0
4588           ityp3=nthetyp+1
4589           do k=1,nsingle
4590             cosph2(k)=0.0d0
4591             sinph2(k)=0.0d0
4592           enddo
4593         endif
4594         ethetai=aa0thet(ityp1,ityp2,ityp3)
4595         do k=1,ndouble
4596           do l=1,k-1
4597             ccl=cosph1(l)*cosph2(k-l)
4598             ssl=sinph1(l)*sinph2(k-l)
4599             scl=sinph1(l)*cosph2(k-l)
4600             csl=cosph1(l)*sinph2(k-l)
4601             cosph1ph2(l,k)=ccl-ssl
4602             cosph1ph2(k,l)=ccl+ssl
4603             sinph1ph2(l,k)=scl+csl
4604             sinph1ph2(k,l)=scl-csl
4605           enddo
4606         enddo
4607         if (lprn) then
4608         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4609      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4610         write (iout,*) "coskt and sinkt"
4611         do k=1,nntheterm
4612           write (iout,*) k,coskt(k),sinkt(k)
4613         enddo
4614         endif
4615         do k=1,ntheterm
4616           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4617           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4618      &      *coskt(k)
4619           if (lprn)
4620      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4621      &     " ethetai",ethetai
4622         enddo
4623         if (lprn) then
4624         write (iout,*) "cosph and sinph"
4625         do k=1,nsingle
4626           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4627         enddo
4628         write (iout,*) "cosph1ph2 and sinph2ph2"
4629         do k=2,ndouble
4630           do l=1,k-1
4631             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4632      &         sinph1ph2(l,k),sinph1ph2(k,l)
4633           enddo
4634         enddo
4635         write(iout,*) "ethetai",ethetai
4636         endif
4637         do m=1,ntheterm2
4638           do k=1,nsingle
4639             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4640      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4641      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4642      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4643             ethetai=ethetai+sinkt(m)*aux
4644             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4645             dephii=dephii+k*sinkt(m)*(
4646      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4647      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4648             dephii1=dephii1+k*sinkt(m)*(
4649      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4650      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4651             if (lprn)
4652      &      write (iout,*) "m",m," k",k," bbthet",
4653      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4654      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4655      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4656      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4657           enddo
4658         enddo
4659         if (lprn)
4660      &  write(iout,*) "ethetai",ethetai
4661         do m=1,ntheterm3
4662           do k=2,ndouble
4663             do l=1,k-1
4664               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4665      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4666      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4667      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4668               ethetai=ethetai+sinkt(m)*aux
4669               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4670               dephii=dephii+l*sinkt(m)*(
4671      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4672      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4673      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4674      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4675               dephii1=dephii1+(k-l)*sinkt(m)*(
4676      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4677      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4678      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4679      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4680               if (lprn) then
4681               write (iout,*) "m",m," k",k," l",l," ffthet",
4682      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4683      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4684      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4685      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4686               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4687      &            cosph1ph2(k,l)*sinkt(m),
4688      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4689               endif
4690             enddo
4691           enddo
4692         enddo
4693 10      continue
4694         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4695      &   i,theta(i)*rad2deg,phii*rad2deg,
4696      &   phii1*rad2deg,ethetai
4697         etheta=etheta+ethetai
4698         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4699         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4700         gloc(nphi+i-2,icg)=wang*dethetai
4701       enddo
4702       return
4703       end
4704 #endif
4705 #ifdef CRYST_SC
4706 c-----------------------------------------------------------------------------
4707       subroutine esc(escloc)
4708 C Calculate the local energy of a side chain and its derivatives in the
4709 C corresponding virtual-bond valence angles THETA and the spherical angles
4710 C ALPHA and OMEGA.
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.GEO'
4714       include 'COMMON.LOCAL'
4715       include 'COMMON.VAR'
4716       include 'COMMON.INTERACT'
4717       include 'COMMON.DERIV'
4718       include 'COMMON.CHAIN'
4719       include 'COMMON.IOUNITS'
4720       include 'COMMON.NAMES'
4721       include 'COMMON.FFIELD'
4722       include 'COMMON.CONTROL'
4723       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4724      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4725       common /sccalc/ time11,time12,time112,theti,it,nlobit
4726       delta=0.02d0*pi
4727       escloc=0.0D0
4728 c     write (iout,'(a)') 'ESC'
4729       do i=loc_start,loc_end
4730         it=itype(i)
4731         if (it.eq.21) cycle
4732         if (it.eq.10) goto 1
4733         nlobit=nlob(it)
4734 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4735 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4736         theti=theta(i+1)-pipol
4737         x(1)=dtan(theti)
4738         x(2)=alph(i)
4739         x(3)=omeg(i)
4740
4741         if (x(2).gt.pi-delta) then
4742           xtemp(1)=x(1)
4743           xtemp(2)=pi-delta
4744           xtemp(3)=x(3)
4745           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4746           xtemp(2)=pi
4747           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4748           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4749      &        escloci,dersc(2))
4750           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4751      &        ddersc0(1),dersc(1))
4752           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4753      &        ddersc0(3),dersc(3))
4754           xtemp(2)=pi-delta
4755           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4756           xtemp(2)=pi
4757           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4758           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4759      &            dersc0(2),esclocbi,dersc02)
4760           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4761      &            dersc12,dersc01)
4762           call splinthet(x(2),0.5d0*delta,ss,ssd)
4763           dersc0(1)=dersc01
4764           dersc0(2)=dersc02
4765           dersc0(3)=0.0d0
4766           do k=1,3
4767             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4768           enddo
4769           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4770 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4771 c    &             esclocbi,ss,ssd
4772           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4773 c         escloci=esclocbi
4774 c         write (iout,*) escloci
4775         else if (x(2).lt.delta) then
4776           xtemp(1)=x(1)
4777           xtemp(2)=delta
4778           xtemp(3)=x(3)
4779           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4780           xtemp(2)=0.0d0
4781           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4782           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4783      &        escloci,dersc(2))
4784           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4785      &        ddersc0(1),dersc(1))
4786           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4787      &        ddersc0(3),dersc(3))
4788           xtemp(2)=delta
4789           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4790           xtemp(2)=0.0d0
4791           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4792           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4793      &            dersc0(2),esclocbi,dersc02)
4794           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4795      &            dersc12,dersc01)
4796           dersc0(1)=dersc01
4797           dersc0(2)=dersc02
4798           dersc0(3)=0.0d0
4799           call splinthet(x(2),0.5d0*delta,ss,ssd)
4800           do k=1,3
4801             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4802           enddo
4803           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4804 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4805 c    &             esclocbi,ss,ssd
4806           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4807 c         write (iout,*) escloci
4808         else
4809           call enesc(x,escloci,dersc,ddummy,.false.)
4810         endif
4811
4812         escloc=escloc+escloci
4813         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4814      &     'escloc',i,escloci
4815 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4816
4817         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4818      &   wscloc*dersc(1)
4819         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4820         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4821     1   continue
4822       enddo
4823       return
4824       end
4825 C---------------------------------------------------------------------------
4826       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4827       implicit real*8 (a-h,o-z)
4828       include 'DIMENSIONS'
4829       include 'COMMON.GEO'
4830       include 'COMMON.LOCAL'
4831       include 'COMMON.IOUNITS'
4832       common /sccalc/ time11,time12,time112,theti,it,nlobit
4833       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4834       double precision contr(maxlob,-1:1)
4835       logical mixed
4836 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4837         escloc_i=0.0D0
4838         do j=1,3
4839           dersc(j)=0.0D0
4840           if (mixed) ddersc(j)=0.0d0
4841         enddo
4842         x3=x(3)
4843
4844 C Because of periodicity of the dependence of the SC energy in omega we have
4845 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4846 C To avoid underflows, first compute & store the exponents.
4847
4848         do iii=-1,1
4849
4850           x(3)=x3+iii*dwapi
4851
4852           do j=1,nlobit
4853             do k=1,3
4854               z(k)=x(k)-censc(k,j,it)
4855             enddo
4856             do k=1,3
4857               Axk=0.0D0
4858               do l=1,3
4859                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4860               enddo
4861               Ax(k,j,iii)=Axk
4862             enddo
4863             expfac=0.0D0
4864             do k=1,3
4865               expfac=expfac+Ax(k,j,iii)*z(k)
4866             enddo
4867             contr(j,iii)=expfac
4868           enddo ! j
4869
4870         enddo ! iii
4871
4872         x(3)=x3
4873 C As in the case of ebend, we want to avoid underflows in exponentiation and
4874 C subsequent NaNs and INFs in energy calculation.
4875 C Find the largest exponent
4876         emin=contr(1,-1)
4877         do iii=-1,1
4878           do j=1,nlobit
4879             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4880           enddo
4881         enddo
4882         emin=0.5D0*emin
4883 cd      print *,'it=',it,' emin=',emin
4884
4885 C Compute the contribution to SC energy and derivatives
4886         do iii=-1,1
4887
4888           do j=1,nlobit
4889 #ifdef OSF
4890             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4891             if(adexp.ne.adexp) adexp=1.0
4892             expfac=dexp(adexp)
4893 #else
4894             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4895 #endif
4896 cd          print *,'j=',j,' expfac=',expfac
4897             escloc_i=escloc_i+expfac
4898             do k=1,3
4899               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4900             enddo
4901             if (mixed) then
4902               do k=1,3,2
4903                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4904      &            +gaussc(k,2,j,it))*expfac
4905               enddo
4906             endif
4907           enddo
4908
4909         enddo ! iii
4910
4911         dersc(1)=dersc(1)/cos(theti)**2
4912         ddersc(1)=ddersc(1)/cos(theti)**2
4913         ddersc(3)=ddersc(3)
4914
4915         escloci=-(dlog(escloc_i)-emin)
4916         do j=1,3
4917           dersc(j)=dersc(j)/escloc_i
4918         enddo
4919         if (mixed) then
4920           do j=1,3,2
4921             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4922           enddo
4923         endif
4924       return
4925       end
4926 C------------------------------------------------------------------------------
4927       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4928       implicit real*8 (a-h,o-z)
4929       include 'DIMENSIONS'
4930       include 'COMMON.GEO'
4931       include 'COMMON.LOCAL'
4932       include 'COMMON.IOUNITS'
4933       common /sccalc/ time11,time12,time112,theti,it,nlobit
4934       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4935       double precision contr(maxlob)
4936       logical mixed
4937
4938       escloc_i=0.0D0
4939
4940       do j=1,3
4941         dersc(j)=0.0D0
4942       enddo
4943
4944       do j=1,nlobit
4945         do k=1,2
4946           z(k)=x(k)-censc(k,j,it)
4947         enddo
4948         z(3)=dwapi
4949         do k=1,3
4950           Axk=0.0D0
4951           do l=1,3
4952             Axk=Axk+gaussc(l,k,j,it)*z(l)
4953           enddo
4954           Ax(k,j)=Axk
4955         enddo
4956         expfac=0.0D0
4957         do k=1,3
4958           expfac=expfac+Ax(k,j)*z(k)
4959         enddo
4960         contr(j)=expfac
4961       enddo ! j
4962
4963 C As in the case of ebend, we want to avoid underflows in exponentiation and
4964 C subsequent NaNs and INFs in energy calculation.
4965 C Find the largest exponent
4966       emin=contr(1)
4967       do j=1,nlobit
4968         if (emin.gt.contr(j)) emin=contr(j)
4969       enddo
4970       emin=0.5D0*emin
4971
4972 C Compute the contribution to SC energy and derivatives
4973
4974       dersc12=0.0d0
4975       do j=1,nlobit
4976         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4977         escloc_i=escloc_i+expfac
4978         do k=1,2
4979           dersc(k)=dersc(k)+Ax(k,j)*expfac
4980         enddo
4981         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4982      &            +gaussc(1,2,j,it))*expfac
4983         dersc(3)=0.0d0
4984       enddo
4985
4986       dersc(1)=dersc(1)/cos(theti)**2
4987       dersc12=dersc12/cos(theti)**2
4988       escloci=-(dlog(escloc_i)-emin)
4989       do j=1,2
4990         dersc(j)=dersc(j)/escloc_i
4991       enddo
4992       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4993       return
4994       end
4995 #else
4996 c----------------------------------------------------------------------------------
4997       subroutine esc(escloc)
4998 C Calculate the local energy of a side chain and its derivatives in the
4999 C corresponding virtual-bond valence angles THETA and the spherical angles
5000 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5001 C added by Urszula Kozlowska. 07/11/2007
5002 C
5003       implicit real*8 (a-h,o-z)
5004       include 'DIMENSIONS'
5005       include 'COMMON.GEO'
5006       include 'COMMON.LOCAL'
5007       include 'COMMON.VAR'
5008       include 'COMMON.SCROT'
5009       include 'COMMON.INTERACT'
5010       include 'COMMON.DERIV'
5011       include 'COMMON.CHAIN'
5012       include 'COMMON.IOUNITS'
5013       include 'COMMON.NAMES'
5014       include 'COMMON.FFIELD'
5015       include 'COMMON.CONTROL'
5016       include 'COMMON.VECTORS'
5017       double precision x_prime(3),y_prime(3),z_prime(3)
5018      &    , sumene,dsc_i,dp2_i,x(65),
5019      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5020      &    de_dxx,de_dyy,de_dzz,de_dt
5021       double precision s1_t,s1_6_t,s2_t,s2_6_t
5022       double precision
5023      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5024      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5025      & dt_dCi(3),dt_dCi1(3)
5026       common /sccalc/ time11,time12,time112,theti,it,nlobit
5027       delta=0.02d0*pi
5028       escloc=0.0D0
5029       do i=loc_start,loc_end
5030         if (itype(i).eq.21) cycle
5031         costtab(i+1) =dcos(theta(i+1))
5032         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5033         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5034         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5035         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5036         cosfac=dsqrt(cosfac2)
5037         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5038         sinfac=dsqrt(sinfac2)
5039         it=itype(i)
5040         if (it.eq.10) goto 1
5041 c
5042 C  Compute the axes of tghe local cartesian coordinates system; store in
5043 c   x_prime, y_prime and z_prime
5044 c
5045         do j=1,3
5046           x_prime(j) = 0.00
5047           y_prime(j) = 0.00
5048           z_prime(j) = 0.00
5049         enddo
5050 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5051 C     &   dc_norm(3,i+nres)
5052         do j = 1,3
5053           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5054           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5055         enddo
5056         do j = 1,3
5057           z_prime(j) = -uz(j,i-1)
5058         enddo
5059 c       write (2,*) "i",i
5060 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5061 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5062 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5063 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5064 c      & " xy",scalar(x_prime(1),y_prime(1)),
5065 c      & " xz",scalar(x_prime(1),z_prime(1)),
5066 c      & " yy",scalar(y_prime(1),y_prime(1)),
5067 c      & " yz",scalar(y_prime(1),z_prime(1)),
5068 c      & " zz",scalar(z_prime(1),z_prime(1))
5069 c
5070 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5071 C to local coordinate system. Store in xx, yy, zz.
5072 c
5073         xx=0.0d0
5074         yy=0.0d0
5075         zz=0.0d0
5076         do j = 1,3
5077           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5078           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5079           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5080         enddo
5081
5082         xxtab(i)=xx
5083         yytab(i)=yy
5084         zztab(i)=zz
5085 C
5086 C Compute the energy of the ith side cbain
5087 C
5088 c        write (2,*) "xx",xx," yy",yy," zz",zz
5089         it=itype(i)
5090         do j = 1,65
5091           x(j) = sc_parmin(j,it)
5092         enddo
5093 #ifdef CHECK_COORD
5094 Cc diagnostics - remove later
5095         xx1 = dcos(alph(2))
5096         yy1 = dsin(alph(2))*dcos(omeg(2))
5097         zz1 = -dsin(alph(2))*dsin(omeg(2))
5098         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5099      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5100      &    xx1,yy1,zz1
5101 C,"  --- ", xx_w,yy_w,zz_w
5102 c end diagnostics
5103 #endif
5104         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5105      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5106      &   + x(10)*yy*zz
5107         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5108      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5109      & + x(20)*yy*zz
5110         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5111      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5112      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5113      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5114      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5115      &  +x(40)*xx*yy*zz
5116         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5117      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5118      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5119      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5120      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5121      &  +x(60)*xx*yy*zz
5122         dsc_i   = 0.743d0+x(61)
5123         dp2_i   = 1.9d0+x(62)
5124         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5125      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5126         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5127      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5128         s1=(1+x(63))/(0.1d0 + dscp1)
5129         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5130         s2=(1+x(65))/(0.1d0 + dscp2)
5131         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5132         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5133      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5134 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5135 c     &   sumene4,
5136 c     &   dscp1,dscp2,sumene
5137 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5138         escloc = escloc + sumene
5139 c        write (2,*) "i",i," escloc",sumene,escloc
5140 #ifdef DEBUG
5141 C
5142 C This section to check the numerical derivatives of the energy of ith side
5143 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5144 C #define DEBUG in the code to turn it on.
5145 C
5146         write (2,*) "sumene               =",sumene
5147         aincr=1.0d-7
5148         xxsave=xx
5149         xx=xx+aincr
5150         write (2,*) xx,yy,zz
5151         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5152         de_dxx_num=(sumenep-sumene)/aincr
5153         xx=xxsave
5154         write (2,*) "xx+ sumene from enesc=",sumenep
5155         yysave=yy
5156         yy=yy+aincr
5157         write (2,*) xx,yy,zz
5158         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5159         de_dyy_num=(sumenep-sumene)/aincr
5160         yy=yysave
5161         write (2,*) "yy+ sumene from enesc=",sumenep
5162         zzsave=zz
5163         zz=zz+aincr
5164         write (2,*) xx,yy,zz
5165         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5166         de_dzz_num=(sumenep-sumene)/aincr
5167         zz=zzsave
5168         write (2,*) "zz+ sumene from enesc=",sumenep
5169         costsave=cost2tab(i+1)
5170         sintsave=sint2tab(i+1)
5171         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5172         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5173         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5174         de_dt_num=(sumenep-sumene)/aincr
5175         write (2,*) " t+ sumene from enesc=",sumenep
5176         cost2tab(i+1)=costsave
5177         sint2tab(i+1)=sintsave
5178 C End of diagnostics section.
5179 #endif
5180 C
5181 C Compute the gradient of esc
5182 C
5183         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5184         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5185         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5186         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5187         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5188         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5189         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5190         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5191         pom1=(sumene3*sint2tab(i+1)+sumene1)
5192      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5193         pom2=(sumene4*cost2tab(i+1)+sumene2)
5194      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5195         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5196         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5197      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5198      &  +x(40)*yy*zz
5199         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5200         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5201      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5202      &  +x(60)*yy*zz
5203         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5204      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5205      &        +(pom1+pom2)*pom_dx
5206 #ifdef DEBUG
5207         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5208 #endif
5209 C
5210         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5211         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5212      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5213      &  +x(40)*xx*zz
5214         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5215         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5216      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5217      &  +x(59)*zz**2 +x(60)*xx*zz
5218         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5219      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5220      &        +(pom1-pom2)*pom_dy
5221 #ifdef DEBUG
5222         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5223 #endif
5224 C
5225         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5226      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5227      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5228      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5229      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5230      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5231      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5232      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5233 #ifdef DEBUG
5234         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5235 #endif
5236 C
5237         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5238      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5239      &  +pom1*pom_dt1+pom2*pom_dt2
5240 #ifdef DEBUG
5241         write(2,*), "de_dt = ", de_dt,de_dt_num
5242 #endif
5243 c
5244 C
5245        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5246        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5247        cosfac2xx=cosfac2*xx
5248        sinfac2yy=sinfac2*yy
5249        do k = 1,3
5250          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5251      &      vbld_inv(i+1)
5252          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5253      &      vbld_inv(i)
5254          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5255          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5256 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5257 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5258 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5259 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5260          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5261          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5262          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5263          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5264          dZZ_Ci1(k)=0.0d0
5265          dZZ_Ci(k)=0.0d0
5266          do j=1,3
5267            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5268            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5269          enddo
5270
5271          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5272          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5273          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5274 c
5275          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5276          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5277        enddo
5278
5279        do k=1,3
5280          dXX_Ctab(k,i)=dXX_Ci(k)
5281          dXX_C1tab(k,i)=dXX_Ci1(k)
5282          dYY_Ctab(k,i)=dYY_Ci(k)
5283          dYY_C1tab(k,i)=dYY_Ci1(k)
5284          dZZ_Ctab(k,i)=dZZ_Ci(k)
5285          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5286          dXX_XYZtab(k,i)=dXX_XYZ(k)
5287          dYY_XYZtab(k,i)=dYY_XYZ(k)
5288          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5289        enddo
5290
5291        do k = 1,3
5292 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5293 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5294 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5295 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5296 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5297 c     &    dt_dci(k)
5298 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5299 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5300          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5301      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5302          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5303      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5304          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5305      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5306        enddo
5307 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5308 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5309
5310 C to check gradient call subroutine check_grad
5311
5312     1 continue
5313       enddo
5314       return
5315       end
5316 c------------------------------------------------------------------------------
5317       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5318       implicit none
5319       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5320      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5321       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5322      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5323      &   + x(10)*yy*zz
5324       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5325      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5326      & + x(20)*yy*zz
5327       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5328      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5329      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5330      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5331      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5332      &  +x(40)*xx*yy*zz
5333       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5334      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5335      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5336      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5337      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5338      &  +x(60)*xx*yy*zz
5339       dsc_i   = 0.743d0+x(61)
5340       dp2_i   = 1.9d0+x(62)
5341       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5342      &          *(xx*cost2+yy*sint2))
5343       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5344      &          *(xx*cost2-yy*sint2))
5345       s1=(1+x(63))/(0.1d0 + dscp1)
5346       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5347       s2=(1+x(65))/(0.1d0 + dscp2)
5348       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5349       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5350      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5351       enesc=sumene
5352       return
5353       end
5354 #endif
5355 c------------------------------------------------------------------------------
5356       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5357 C
5358 C This procedure calculates two-body contact function g(rij) and its derivative:
5359 C
5360 C           eps0ij                                     !       x < -1
5361 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5362 C            0                                         !       x > 1
5363 C
5364 C where x=(rij-r0ij)/delta
5365 C
5366 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5367 C
5368       implicit none
5369       double precision rij,r0ij,eps0ij,fcont,fprimcont
5370       double precision x,x2,x4,delta
5371 c     delta=0.02D0*r0ij
5372 c      delta=0.2D0*r0ij
5373       x=(rij-r0ij)/delta
5374       if (x.lt.-1.0D0) then
5375         fcont=eps0ij
5376         fprimcont=0.0D0
5377       else if (x.le.1.0D0) then
5378         x2=x*x
5379         x4=x2*x2
5380         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5381         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5382       else
5383         fcont=0.0D0
5384         fprimcont=0.0D0
5385       endif
5386       return
5387       end
5388 c------------------------------------------------------------------------------
5389       subroutine splinthet(theti,delta,ss,ssder)
5390       implicit real*8 (a-h,o-z)
5391       include 'DIMENSIONS'
5392       include 'COMMON.VAR'
5393       include 'COMMON.GEO'
5394       thetup=pi-delta
5395       thetlow=delta
5396       if (theti.gt.pipol) then
5397         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5398       else
5399         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5400         ssder=-ssder
5401       endif
5402       return
5403       end
5404 c------------------------------------------------------------------------------
5405       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5406       implicit none
5407       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5408       double precision ksi,ksi2,ksi3,a1,a2,a3
5409       a1=fprim0*delta/(f1-f0)
5410       a2=3.0d0-2.0d0*a1
5411       a3=a1-2.0d0
5412       ksi=(x-x0)/delta
5413       ksi2=ksi*ksi
5414       ksi3=ksi2*ksi
5415       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5416       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5417       return
5418       end
5419 c------------------------------------------------------------------------------
5420       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5421       implicit none
5422       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5423       double precision ksi,ksi2,ksi3,a1,a2,a3
5424       ksi=(x-x0)/delta
5425       ksi2=ksi*ksi
5426       ksi3=ksi2*ksi
5427       a1=fprim0x*delta
5428       a2=3*(f1x-f0x)-2*fprim0x*delta
5429       a3=fprim0x*delta-2*(f1x-f0x)
5430       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5431       return
5432       end
5433 C-----------------------------------------------------------------------------
5434 #ifdef CRYST_TOR
5435 C-----------------------------------------------------------------------------
5436       subroutine etor(etors,edihcnstr)
5437       implicit real*8 (a-h,o-z)
5438       include 'DIMENSIONS'
5439       include 'COMMON.VAR'
5440       include 'COMMON.GEO'
5441       include 'COMMON.LOCAL'
5442       include 'COMMON.TORSION'
5443       include 'COMMON.INTERACT'
5444       include 'COMMON.DERIV'
5445       include 'COMMON.CHAIN'
5446       include 'COMMON.NAMES'
5447       include 'COMMON.IOUNITS'
5448       include 'COMMON.FFIELD'
5449       include 'COMMON.TORCNSTR'
5450       include 'COMMON.CONTROL'
5451       logical lprn
5452 C Set lprn=.true. for debugging
5453       lprn=.false.
5454 c      lprn=.true.
5455       etors=0.0D0
5456       do i=iphi_start,iphi_end
5457       etors_ii=0.0D0
5458         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5459      &      .or. itype(i).eq.21) cycle
5460         itori=itortyp(itype(i-2))
5461         itori1=itortyp(itype(i-1))
5462         phii=phi(i)
5463         gloci=0.0D0
5464 C Proline-Proline pair is a special case...
5465         if (itori.eq.3 .and. itori1.eq.3) then
5466           if (phii.gt.-dwapi3) then
5467             cosphi=dcos(3*phii)
5468             fac=1.0D0/(1.0D0-cosphi)
5469             etorsi=v1(1,3,3)*fac
5470             etorsi=etorsi+etorsi
5471             etors=etors+etorsi-v1(1,3,3)
5472             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5473             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5474           endif
5475           do j=1,3
5476             v1ij=v1(j+1,itori,itori1)
5477             v2ij=v2(j+1,itori,itori1)
5478             cosphi=dcos(j*phii)
5479             sinphi=dsin(j*phii)
5480             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5481             if (energy_dec) etors_ii=etors_ii+
5482      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5483             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5484           enddo
5485         else
5486           do j=1,nterm_old
5487             v1ij=v1(j,itori,itori1)
5488             v2ij=v2(j,itori,itori1)
5489             cosphi=dcos(j*phii)
5490             sinphi=dsin(j*phii)
5491             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5492             if (energy_dec) etors_ii=etors_ii+
5493      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5494             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5495           enddo
5496         endif
5497         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5498              'etor',i,etors_ii
5499         if (lprn)
5500      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5501      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5502      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5503         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5504 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5505       enddo
5506 ! 6/20/98 - dihedral angle constraints
5507       edihcnstr=0.0d0
5508       do i=1,ndih_constr
5509         itori=idih_constr(i)
5510         phii=phi(itori)
5511         difi=phii-phi0(i)
5512         if (difi.gt.drange(i)) then
5513           difi=difi-drange(i)
5514           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5515           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5516         else if (difi.lt.-drange(i)) then
5517           difi=difi+drange(i)
5518           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5519           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5520         endif
5521 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5522 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5523       enddo
5524 !      write (iout,*) 'edihcnstr',edihcnstr
5525       return
5526       end
5527 c------------------------------------------------------------------------------
5528       subroutine etor_d(etors_d)
5529       etors_d=0.0d0
5530       return
5531       end
5532 c----------------------------------------------------------------------------
5533 #else
5534       subroutine etor(etors,edihcnstr)
5535       implicit real*8 (a-h,o-z)
5536       include 'DIMENSIONS'
5537       include 'COMMON.VAR'
5538       include 'COMMON.GEO'
5539       include 'COMMON.LOCAL'
5540       include 'COMMON.TORSION'
5541       include 'COMMON.INTERACT'
5542       include 'COMMON.DERIV'
5543       include 'COMMON.CHAIN'
5544       include 'COMMON.NAMES'
5545       include 'COMMON.IOUNITS'
5546       include 'COMMON.FFIELD'
5547       include 'COMMON.TORCNSTR'
5548       include 'COMMON.CONTROL'
5549       logical lprn
5550 C Set lprn=.true. for debugging
5551       lprn=.false.
5552 c     lprn=.true.
5553       etors=0.0D0
5554       do i=iphi_start,iphi_end
5555         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5556      &       .or. itype(i).eq.21) cycle
5557       etors_ii=0.0D0
5558         itori=itortyp(itype(i-2))
5559         itori1=itortyp(itype(i-1))
5560         phii=phi(i)
5561         gloci=0.0D0
5562 C Regular cosine and sine terms
5563         do j=1,nterm(itori,itori1)
5564           v1ij=v1(j,itori,itori1)
5565           v2ij=v2(j,itori,itori1)
5566           cosphi=dcos(j*phii)
5567           sinphi=dsin(j*phii)
5568           etors=etors+v1ij*cosphi+v2ij*sinphi
5569           if (energy_dec) etors_ii=etors_ii+
5570      &                v1ij*cosphi+v2ij*sinphi
5571           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5572         enddo
5573 C Lorentz terms
5574 C                         v1
5575 C  E = SUM ----------------------------------- - v1
5576 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5577 C
5578         cosphi=dcos(0.5d0*phii)
5579         sinphi=dsin(0.5d0*phii)
5580         do j=1,nlor(itori,itori1)
5581           vl1ij=vlor1(j,itori,itori1)
5582           vl2ij=vlor2(j,itori,itori1)
5583           vl3ij=vlor3(j,itori,itori1)
5584           pom=vl2ij*cosphi+vl3ij*sinphi
5585           pom1=1.0d0/(pom*pom+1.0d0)
5586           etors=etors+vl1ij*pom1
5587           if (energy_dec) etors_ii=etors_ii+
5588      &                vl1ij*pom1
5589           pom=-pom*pom1*pom1
5590           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5591         enddo
5592 C Subtract the constant term
5593         etors=etors-v0(itori,itori1)
5594           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5595      &         'etor',i,etors_ii-v0(itori,itori1)
5596         if (lprn)
5597      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5598      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5599      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5600         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5601 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5602       enddo
5603 ! 6/20/98 - dihedral angle constraints
5604       edihcnstr=0.0d0
5605 c      do i=1,ndih_constr
5606       do i=idihconstr_start,idihconstr_end
5607         itori=idih_constr(i)
5608         phii=phi(itori)
5609         difi=pinorm(phii-phi0(i))
5610         if (difi.gt.drange(i)) then
5611           difi=difi-drange(i)
5612           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5613           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5614         else if (difi.lt.-drange(i)) then
5615           difi=difi+drange(i)
5616           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5617           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5618         else
5619           difi=0.0
5620         endif
5621 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5622 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5623 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5624       enddo
5625 cd       write (iout,*) 'edihcnstr',edihcnstr
5626       return
5627       end
5628 c----------------------------------------------------------------------------
5629       subroutine etor_d(etors_d)
5630 C 6/23/01 Compute double torsional energy
5631       implicit real*8 (a-h,o-z)
5632       include 'DIMENSIONS'
5633       include 'COMMON.VAR'
5634       include 'COMMON.GEO'
5635       include 'COMMON.LOCAL'
5636       include 'COMMON.TORSION'
5637       include 'COMMON.INTERACT'
5638       include 'COMMON.DERIV'
5639       include 'COMMON.CHAIN'
5640       include 'COMMON.NAMES'
5641       include 'COMMON.IOUNITS'
5642       include 'COMMON.FFIELD'
5643       include 'COMMON.TORCNSTR'
5644       logical lprn
5645 C Set lprn=.true. for debugging
5646       lprn=.false.
5647 c     lprn=.true.
5648       etors_d=0.0D0
5649 c      write(iout,*) "a tu??"
5650       do i=iphid_start,iphid_end
5651         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5652      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5653         itori=itortyp(itype(i-2))
5654         itori1=itortyp(itype(i-1))
5655         itori2=itortyp(itype(i))
5656         phii=phi(i)
5657         phii1=phi(i+1)
5658         gloci1=0.0D0
5659         gloci2=0.0D0
5660 C Regular cosine and sine terms
5661         do j=1,ntermd_1(itori,itori1,itori2)
5662           v1cij=v1c(1,j,itori,itori1,itori2)
5663           v1sij=v1s(1,j,itori,itori1,itori2)
5664           v2cij=v1c(2,j,itori,itori1,itori2)
5665           v2sij=v1s(2,j,itori,itori1,itori2)
5666           cosphi1=dcos(j*phii)
5667           sinphi1=dsin(j*phii)
5668           cosphi2=dcos(j*phii1)
5669           sinphi2=dsin(j*phii1)
5670           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5671      &     v2cij*cosphi2+v2sij*sinphi2
5672           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5673           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5674         enddo
5675         do k=2,ntermd_2(itori,itori1,itori2)
5676           do l=1,k-1
5677             v1cdij = v2c(k,l,itori,itori1,itori2)
5678             v2cdij = v2c(l,k,itori,itori1,itori2)
5679             v1sdij = v2s(k,l,itori,itori1,itori2)
5680             v2sdij = v2s(l,k,itori,itori1,itori2)
5681             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5682             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5683             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5684             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5685             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5686      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5687             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5688      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5689             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5690      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5691           enddo
5692         enddo
5693         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5694         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5695       enddo
5696       return
5697       end
5698 #endif
5699 c------------------------------------------------------------------------------
5700       subroutine eback_sc_corr(esccor)
5701 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5702 c        conformational states; temporarily implemented as differences
5703 c        between UNRES torsional potentials (dependent on three types of
5704 c        residues) and the torsional potentials dependent on all 20 types
5705 c        of residues computed from AM1  energy surfaces of terminally-blocked
5706 c        amino-acid residues.
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.VAR'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.TORSION'
5713       include 'COMMON.SCCOR'
5714       include 'COMMON.INTERACT'
5715       include 'COMMON.DERIV'
5716       include 'COMMON.CHAIN'
5717       include 'COMMON.NAMES'
5718       include 'COMMON.IOUNITS'
5719       include 'COMMON.FFIELD'
5720       include 'COMMON.CONTROL'
5721       logical lprn
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724 c      lprn=.true.
5725 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5726       esccor=0.0D0
5727       do i=itau_start,itau_end
5728         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5729         esccor_ii=0.0D0
5730         isccori=isccortyp(itype(i-2))
5731         isccori1=isccortyp(itype(i-1))
5732 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5733         phii=phi(i)
5734         do intertyp=1,3 !intertyp
5735 cc Added 09 May 2012 (Adasko)
5736 cc  Intertyp means interaction type of backbone mainchain correlation:
5737 c   1 = SC...Ca...Ca...Ca
5738 c   2 = Ca...Ca...Ca...SC
5739 c   3 = SC...Ca...Ca...SCi
5740         gloci=0.0D0
5741         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5742      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5743      &      (itype(i-1).eq.ntyp1)))
5744      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5745      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5746      &     .or.(itype(i).eq.ntyp1)))
5747      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5748      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5749      &      (itype(i-3).eq.ntyp1)))) cycle
5750         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5751         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5752      & cycle
5753        do j=1,nterm_sccor(isccori,isccori1)
5754           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5755           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5756           cosphi=dcos(j*tauangle(intertyp,i))
5757           sinphi=dsin(j*tauangle(intertyp,i))
5758           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5759           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5760         enddo
5761 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5762         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5763         if (lprn)
5764      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5765      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5766      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5767      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5768         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5769        enddo !intertyp
5770       enddo
5771
5772       return
5773       end
5774 c----------------------------------------------------------------------------
5775       subroutine multibody(ecorr)
5776 C This subroutine calculates multi-body contributions to energy following
5777 C the idea of Skolnick et al. If side chains I and J make a contact and
5778 C at the same time side chains I+1 and J+1 make a contact, an extra
5779 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
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
5789 C Set lprn=.true. for debugging
5790       lprn=.false.
5791
5792       if (lprn) then
5793         write (iout,'(a)') 'Contact function values:'
5794         do i=nnt,nct-2
5795           write (iout,'(i2,20(1x,i2,f10.5))')
5796      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5797         enddo
5798       endif
5799       ecorr=0.0D0
5800       do i=nnt,nct
5801         do j=1,3
5802           gradcorr(j,i)=0.0D0
5803           gradxorr(j,i)=0.0D0
5804         enddo
5805       enddo
5806       do i=nnt,nct-2
5807
5808         DO ISHIFT = 3,4
5809
5810         i1=i+ishift
5811         num_conti=num_cont(i)
5812         num_conti1=num_cont(i1)
5813         do jj=1,num_conti
5814           j=jcont(jj,i)
5815           do kk=1,num_conti1
5816             j1=jcont(kk,i1)
5817             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5818 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5819 cd   &                   ' ishift=',ishift
5820 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5821 C The system gains extra energy.
5822               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5823             endif   ! j1==j+-ishift
5824           enddo     ! kk
5825         enddo       ! jj
5826
5827         ENDDO ! ISHIFT
5828
5829       enddo         ! i
5830       return
5831       end
5832 c------------------------------------------------------------------------------
5833       double precision function esccorr(i,j,k,l,jj,kk)
5834       implicit real*8 (a-h,o-z)
5835       include 'DIMENSIONS'
5836       include 'COMMON.IOUNITS'
5837       include 'COMMON.DERIV'
5838       include 'COMMON.INTERACT'
5839       include 'COMMON.CONTACTS'
5840       double precision gx(3),gx1(3)
5841       logical lprn
5842       lprn=.false.
5843       eij=facont(jj,i)
5844       ekl=facont(kk,k)
5845 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5846 C Calculate the multi-body contribution to energy.
5847 C Calculate multi-body contributions to the gradient.
5848 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5849 cd   & k,l,(gacont(m,kk,k),m=1,3)
5850       do m=1,3
5851         gx(m) =ekl*gacont(m,jj,i)
5852         gx1(m)=eij*gacont(m,kk,k)
5853         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5854         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5855         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5856         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5857       enddo
5858       do m=i,j-1
5859         do ll=1,3
5860           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5861         enddo
5862       enddo
5863       do m=k,l-1
5864         do ll=1,3
5865           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5866         enddo
5867       enddo
5868       esccorr=-eij*ekl
5869       return
5870       end
5871 c------------------------------------------------------------------------------
5872       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5873 C This subroutine calculates multi-body contributions to hydrogen-bonding
5874       implicit real*8 (a-h,o-z)
5875       include 'DIMENSIONS'
5876       include 'COMMON.IOUNITS'
5877 #ifdef MPI
5878       include "mpif.h"
5879       parameter (max_cont=maxconts)
5880       parameter (max_dim=26)
5881       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5882       double precision zapas(max_dim,maxconts,max_fg_procs),
5883      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5884       common /przechowalnia/ zapas
5885       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5886      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5887 #endif
5888       include 'COMMON.SETUP'
5889       include 'COMMON.FFIELD'
5890       include 'COMMON.DERIV'
5891       include 'COMMON.INTERACT'
5892       include 'COMMON.CONTACTS'
5893       include 'COMMON.CONTROL'
5894       include 'COMMON.LOCAL'
5895       double precision gx(3),gx1(3),time00
5896       logical lprn,ldone
5897
5898 C Set lprn=.true. for debugging
5899       lprn=.false.
5900 #ifdef MPI
5901       n_corr=0
5902       n_corr1=0
5903       if (nfgtasks.le.1) goto 30
5904       if (lprn) then
5905         write (iout,'(a)') 'Contact function values before RECEIVE:'
5906         do i=nnt,nct-2
5907           write (iout,'(2i3,50(1x,i2,f5.2))')
5908      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5909      &    j=1,num_cont_hb(i))
5910         enddo
5911       endif
5912       call flush(iout)
5913       do i=1,ntask_cont_from
5914         ncont_recv(i)=0
5915       enddo
5916       do i=1,ntask_cont_to
5917         ncont_sent(i)=0
5918       enddo
5919 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5920 c     & ntask_cont_to
5921 C Make the list of contacts to send to send to other procesors
5922 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5923 c      call flush(iout)
5924       do i=iturn3_start,iturn3_end
5925 c        write (iout,*) "make contact list turn3",i," num_cont",
5926 c     &    num_cont_hb(i)
5927         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5928       enddo
5929       do i=iturn4_start,iturn4_end
5930 c        write (iout,*) "make contact list turn4",i," num_cont",
5931 c     &   num_cont_hb(i)
5932         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5933       enddo
5934       do ii=1,nat_sent
5935         i=iat_sent(ii)
5936 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5937 c     &    num_cont_hb(i)
5938         do j=1,num_cont_hb(i)
5939         do k=1,4
5940           jjc=jcont_hb(j,i)
5941           iproc=iint_sent_local(k,jjc,ii)
5942 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5943           if (iproc.gt.0) then
5944             ncont_sent(iproc)=ncont_sent(iproc)+1
5945             nn=ncont_sent(iproc)
5946             zapas(1,nn,iproc)=i
5947             zapas(2,nn,iproc)=jjc
5948             zapas(3,nn,iproc)=facont_hb(j,i)
5949             zapas(4,nn,iproc)=ees0p(j,i)
5950             zapas(5,nn,iproc)=ees0m(j,i)
5951             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5952             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5953             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5954             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5955             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5956             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5957             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5958             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5959             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5960             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5961             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5962             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5963             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5964             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5965             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5966             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5967             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5968             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5969             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5970             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5971             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5972           endif
5973         enddo
5974         enddo
5975       enddo
5976       if (lprn) then
5977       write (iout,*)
5978      &  "Numbers of contacts to be sent to other processors",
5979      &  (ncont_sent(i),i=1,ntask_cont_to)
5980       write (iout,*) "Contacts sent"
5981       do ii=1,ntask_cont_to
5982         nn=ncont_sent(ii)
5983         iproc=itask_cont_to(ii)
5984         write (iout,*) nn," contacts to processor",iproc,
5985      &   " of CONT_TO_COMM group"
5986         do i=1,nn
5987           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5988         enddo
5989       enddo
5990       call flush(iout)
5991       endif
5992       CorrelType=477
5993       CorrelID=fg_rank+1
5994       CorrelType1=478
5995       CorrelID1=nfgtasks+fg_rank+1
5996       ireq=0
5997 C Receive the numbers of needed contacts from other processors
5998       do ii=1,ntask_cont_from
5999         iproc=itask_cont_from(ii)
6000         ireq=ireq+1
6001         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6002      &    FG_COMM,req(ireq),IERR)
6003       enddo
6004 c      write (iout,*) "IRECV ended"
6005 c      call flush(iout)
6006 C Send the number of contacts needed by other processors
6007       do ii=1,ntask_cont_to
6008         iproc=itask_cont_to(ii)
6009         ireq=ireq+1
6010         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6011      &    FG_COMM,req(ireq),IERR)
6012       enddo
6013 c      write (iout,*) "ISEND ended"
6014 c      write (iout,*) "number of requests (nn)",ireq
6015       call flush(iout)
6016       if (ireq.gt.0)
6017      &  call MPI_Waitall(ireq,req,status_array,ierr)
6018 c      write (iout,*)
6019 c     &  "Numbers of contacts to be received from other processors",
6020 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6021 c      call flush(iout)
6022 C Receive contacts
6023       ireq=0
6024       do ii=1,ntask_cont_from
6025         iproc=itask_cont_from(ii)
6026         nn=ncont_recv(ii)
6027 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6028 c     &   " of CONT_TO_COMM group"
6029         call flush(iout)
6030         if (nn.gt.0) then
6031           ireq=ireq+1
6032           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6033      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6034 c          write (iout,*) "ireq,req",ireq,req(ireq)
6035         endif
6036       enddo
6037 C Send the contacts to processors that need them
6038       do ii=1,ntask_cont_to
6039         iproc=itask_cont_to(ii)
6040         nn=ncont_sent(ii)
6041 c        write (iout,*) nn," contacts to processor",iproc,
6042 c     &   " of CONT_TO_COMM group"
6043         if (nn.gt.0) then
6044           ireq=ireq+1
6045           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6046      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6047 c          write (iout,*) "ireq,req",ireq,req(ireq)
6048 c          do i=1,nn
6049 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6050 c          enddo
6051         endif
6052       enddo
6053 c      write (iout,*) "number of requests (contacts)",ireq
6054 c      write (iout,*) "req",(req(i),i=1,4)
6055 c      call flush(iout)
6056       if (ireq.gt.0)
6057      & call MPI_Waitall(ireq,req,status_array,ierr)
6058       do iii=1,ntask_cont_from
6059         iproc=itask_cont_from(iii)
6060         nn=ncont_recv(iii)
6061         if (lprn) then
6062         write (iout,*) "Received",nn," contacts from processor",iproc,
6063      &   " of CONT_FROM_COMM group"
6064         call flush(iout)
6065         do i=1,nn
6066           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6067         enddo
6068         call flush(iout)
6069         endif
6070         do i=1,nn
6071           ii=zapas_recv(1,i,iii)
6072 c Flag the received contacts to prevent double-counting
6073           jj=-zapas_recv(2,i,iii)
6074 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6075 c          call flush(iout)
6076           nnn=num_cont_hb(ii)+1
6077           num_cont_hb(ii)=nnn
6078           jcont_hb(nnn,ii)=jj
6079           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6080           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6081           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6082           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6083           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6084           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6085           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6086           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6087           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6088           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6089           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6090           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6091           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6092           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6093           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6094           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6095           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6096           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6097           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6098           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6099           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6100           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6101           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6102           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6103         enddo
6104       enddo
6105       call flush(iout)
6106       if (lprn) then
6107         write (iout,'(a)') 'Contact function values after receive:'
6108         do i=nnt,nct-2
6109           write (iout,'(2i3,50(1x,i3,f5.2))')
6110      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6111      &    j=1,num_cont_hb(i))
6112         enddo
6113         call flush(iout)
6114       endif
6115    30 continue
6116 #endif
6117       if (lprn) then
6118         write (iout,'(a)') 'Contact function values:'
6119         do i=nnt,nct-2
6120           write (iout,'(2i3,50(1x,i3,f5.2))')
6121      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6122      &    j=1,num_cont_hb(i))
6123         enddo
6124       endif
6125       ecorr=0.0D0
6126 C Remove the loop below after debugging !!!
6127       do i=nnt,nct
6128         do j=1,3
6129           gradcorr(j,i)=0.0D0
6130           gradxorr(j,i)=0.0D0
6131         enddo
6132       enddo
6133 C Calculate the local-electrostatic correlation terms
6134       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6135         i1=i+1
6136         num_conti=num_cont_hb(i)
6137         num_conti1=num_cont_hb(i+1)
6138         do jj=1,num_conti
6139           j=jcont_hb(jj,i)
6140           jp=iabs(j)
6141           do kk=1,num_conti1
6142             j1=jcont_hb(kk,i1)
6143             jp1=iabs(j1)
6144 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6145 c     &         ' jj=',jj,' kk=',kk
6146             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6147      &          .or. j.lt.0 .and. j1.gt.0) .and.
6148      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6149 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6150 C The system gains extra energy.
6151               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6152               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6153      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6154               n_corr=n_corr+1
6155             else if (j1.eq.j) then
6156 C Contacts I-J and I-(J+1) occur simultaneously.
6157 C The system loses extra energy.
6158 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6159             endif
6160           enddo ! kk
6161           do kk=1,num_conti
6162             j1=jcont_hb(kk,i)
6163 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6164 c    &         ' jj=',jj,' kk=',kk
6165             if (j1.eq.j+1) then
6166 C Contacts I-J and (I+1)-J occur simultaneously.
6167 C The system loses extra energy.
6168 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6169             endif ! j1==j+1
6170           enddo ! kk
6171         enddo ! jj
6172       enddo ! i
6173       return
6174       end
6175 c------------------------------------------------------------------------------
6176       subroutine add_hb_contact(ii,jj,itask)
6177       implicit real*8 (a-h,o-z)
6178       include "DIMENSIONS"
6179       include "COMMON.IOUNITS"
6180       integer max_cont
6181       integer max_dim
6182       parameter (max_cont=maxconts)
6183       parameter (max_dim=26)
6184       include "COMMON.CONTACTS"
6185       double precision zapas(max_dim,maxconts,max_fg_procs),
6186      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6187       common /przechowalnia/ zapas
6188       integer i,j,ii,jj,iproc,itask(4),nn
6189 c      write (iout,*) "itask",itask
6190       do i=1,2
6191         iproc=itask(i)
6192         if (iproc.gt.0) then
6193           do j=1,num_cont_hb(ii)
6194             jjc=jcont_hb(j,ii)
6195 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6196             if (jjc.eq.jj) then
6197               ncont_sent(iproc)=ncont_sent(iproc)+1
6198               nn=ncont_sent(iproc)
6199               zapas(1,nn,iproc)=ii
6200               zapas(2,nn,iproc)=jjc
6201               zapas(3,nn,iproc)=facont_hb(j,ii)
6202               zapas(4,nn,iproc)=ees0p(j,ii)
6203               zapas(5,nn,iproc)=ees0m(j,ii)
6204               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6205               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6206               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6207               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6208               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6209               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6210               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6211               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6212               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6213               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6214               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6215               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6216               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6217               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6218               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6219               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6220               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6221               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6222               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6223               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6224               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6225               exit
6226             endif
6227           enddo
6228         endif
6229       enddo
6230       return
6231       end
6232 c------------------------------------------------------------------------------
6233       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6234      &  n_corr1)
6235 C This subroutine calculates multi-body contributions to hydrogen-bonding
6236       implicit real*8 (a-h,o-z)
6237       include 'DIMENSIONS'
6238       include 'COMMON.IOUNITS'
6239 #ifdef MPI
6240       include "mpif.h"
6241       parameter (max_cont=maxconts)
6242       parameter (max_dim=70)
6243       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6244       double precision zapas(max_dim,maxconts,max_fg_procs),
6245      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6246       common /przechowalnia/ zapas
6247       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6248      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6249 #endif
6250       include 'COMMON.SETUP'
6251       include 'COMMON.FFIELD'
6252       include 'COMMON.DERIV'
6253       include 'COMMON.LOCAL'
6254       include 'COMMON.INTERACT'
6255       include 'COMMON.CONTACTS'
6256       include 'COMMON.CHAIN'
6257       include 'COMMON.CONTROL'
6258       double precision gx(3),gx1(3)
6259       integer num_cont_hb_old(maxres)
6260       logical lprn,ldone
6261       double precision eello4,eello5,eelo6,eello_turn6
6262       external eello4,eello5,eello6,eello_turn6
6263 C Set lprn=.true. for debugging
6264       lprn=.false.
6265       eturn6=0.0d0
6266 #ifdef MPI
6267       do i=1,nres
6268         num_cont_hb_old(i)=num_cont_hb(i)
6269       enddo
6270       n_corr=0
6271       n_corr1=0
6272       if (nfgtasks.le.1) goto 30
6273       if (lprn) then
6274         write (iout,'(a)') 'Contact function values before RECEIVE:'
6275         do i=nnt,nct-2
6276           write (iout,'(2i3,50(1x,i2,f5.2))')
6277      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6278      &    j=1,num_cont_hb(i))
6279         enddo
6280       endif
6281       call flush(iout)
6282       do i=1,ntask_cont_from
6283         ncont_recv(i)=0
6284       enddo
6285       do i=1,ntask_cont_to
6286         ncont_sent(i)=0
6287       enddo
6288 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6289 c     & ntask_cont_to
6290 C Make the list of contacts to send to send to other procesors
6291       do i=iturn3_start,iturn3_end
6292 c        write (iout,*) "make contact list turn3",i," num_cont",
6293 c     &    num_cont_hb(i)
6294         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6295       enddo
6296       do i=iturn4_start,iturn4_end
6297 c        write (iout,*) "make contact list turn4",i," num_cont",
6298 c     &   num_cont_hb(i)
6299         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6300       enddo
6301       do ii=1,nat_sent
6302         i=iat_sent(ii)
6303 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6304 c     &    num_cont_hb(i)
6305         do j=1,num_cont_hb(i)
6306         do k=1,4
6307           jjc=jcont_hb(j,i)
6308           iproc=iint_sent_local(k,jjc,ii)
6309 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6310           if (iproc.ne.0) then
6311             ncont_sent(iproc)=ncont_sent(iproc)+1
6312             nn=ncont_sent(iproc)
6313             zapas(1,nn,iproc)=i
6314             zapas(2,nn,iproc)=jjc
6315             zapas(3,nn,iproc)=d_cont(j,i)
6316             ind=3
6317             do kk=1,3
6318               ind=ind+1
6319               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6320             enddo
6321             do kk=1,2
6322               do ll=1,2
6323                 ind=ind+1
6324                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6325               enddo
6326             enddo
6327             do jj=1,5
6328               do kk=1,3
6329                 do ll=1,2
6330                   do mm=1,2
6331                     ind=ind+1
6332                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6333                   enddo
6334                 enddo
6335               enddo
6336             enddo
6337           endif
6338         enddo
6339         enddo
6340       enddo
6341       if (lprn) then
6342       write (iout,*)
6343      &  "Numbers of contacts to be sent to other processors",
6344      &  (ncont_sent(i),i=1,ntask_cont_to)
6345       write (iout,*) "Contacts sent"
6346       do ii=1,ntask_cont_to
6347         nn=ncont_sent(ii)
6348         iproc=itask_cont_to(ii)
6349         write (iout,*) nn," contacts to processor",iproc,
6350      &   " of CONT_TO_COMM group"
6351         do i=1,nn
6352           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6353         enddo
6354       enddo
6355       call flush(iout)
6356       endif
6357       CorrelType=477
6358       CorrelID=fg_rank+1
6359       CorrelType1=478
6360       CorrelID1=nfgtasks+fg_rank+1
6361       ireq=0
6362 C Receive the numbers of needed contacts from other processors
6363       do ii=1,ntask_cont_from
6364         iproc=itask_cont_from(ii)
6365         ireq=ireq+1
6366         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6367      &    FG_COMM,req(ireq),IERR)
6368       enddo
6369 c      write (iout,*) "IRECV ended"
6370 c      call flush(iout)
6371 C Send the number of contacts needed by other processors
6372       do ii=1,ntask_cont_to
6373         iproc=itask_cont_to(ii)
6374         ireq=ireq+1
6375         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6376      &    FG_COMM,req(ireq),IERR)
6377       enddo
6378 c      write (iout,*) "ISEND ended"
6379 c      write (iout,*) "number of requests (nn)",ireq
6380       call flush(iout)
6381       if (ireq.gt.0)
6382      &  call MPI_Waitall(ireq,req,status_array,ierr)
6383 c      write (iout,*)
6384 c     &  "Numbers of contacts to be received from other processors",
6385 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6386 c      call flush(iout)
6387 C Receive contacts
6388       ireq=0
6389       do ii=1,ntask_cont_from
6390         iproc=itask_cont_from(ii)
6391         nn=ncont_recv(ii)
6392 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6393 c     &   " of CONT_TO_COMM group"
6394         call flush(iout)
6395         if (nn.gt.0) then
6396           ireq=ireq+1
6397           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6398      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6399 c          write (iout,*) "ireq,req",ireq,req(ireq)
6400         endif
6401       enddo
6402 C Send the contacts to processors that need them
6403       do ii=1,ntask_cont_to
6404         iproc=itask_cont_to(ii)
6405         nn=ncont_sent(ii)
6406 c        write (iout,*) nn," contacts to processor",iproc,
6407 c     &   " of CONT_TO_COMM group"
6408         if (nn.gt.0) then
6409           ireq=ireq+1
6410           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6411      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6412 c          write (iout,*) "ireq,req",ireq,req(ireq)
6413 c          do i=1,nn
6414 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6415 c          enddo
6416         endif
6417       enddo
6418 c      write (iout,*) "number of requests (contacts)",ireq
6419 c      write (iout,*) "req",(req(i),i=1,4)
6420 c      call flush(iout)
6421       if (ireq.gt.0)
6422      & call MPI_Waitall(ireq,req,status_array,ierr)
6423       do iii=1,ntask_cont_from
6424         iproc=itask_cont_from(iii)
6425         nn=ncont_recv(iii)
6426         if (lprn) then
6427         write (iout,*) "Received",nn," contacts from processor",iproc,
6428      &   " of CONT_FROM_COMM group"
6429         call flush(iout)
6430         do i=1,nn
6431           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6432         enddo
6433         call flush(iout)
6434         endif
6435         do i=1,nn
6436           ii=zapas_recv(1,i,iii)
6437 c Flag the received contacts to prevent double-counting
6438           jj=-zapas_recv(2,i,iii)
6439 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6440 c          call flush(iout)
6441           nnn=num_cont_hb(ii)+1
6442           num_cont_hb(ii)=nnn
6443           jcont_hb(nnn,ii)=jj
6444           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6445           ind=3
6446           do kk=1,3
6447             ind=ind+1
6448             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6449           enddo
6450           do kk=1,2
6451             do ll=1,2
6452               ind=ind+1
6453               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6454             enddo
6455           enddo
6456           do jj=1,5
6457             do kk=1,3
6458               do ll=1,2
6459                 do mm=1,2
6460                   ind=ind+1
6461                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6462                 enddo
6463               enddo
6464             enddo
6465           enddo
6466         enddo
6467       enddo
6468       call flush(iout)
6469       if (lprn) then
6470         write (iout,'(a)') 'Contact function values after receive:'
6471         do i=nnt,nct-2
6472           write (iout,'(2i3,50(1x,i3,5f6.3))')
6473      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6474      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6475         enddo
6476         call flush(iout)
6477       endif
6478    30 continue
6479 #endif
6480       if (lprn) then
6481         write (iout,'(a)') 'Contact function values:'
6482         do i=nnt,nct-2
6483           write (iout,'(2i3,50(1x,i2,5f6.3))')
6484      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6485      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6486         enddo
6487       endif
6488       ecorr=0.0D0
6489       ecorr5=0.0d0
6490       ecorr6=0.0d0
6491 C Remove the loop below after debugging !!!
6492       do i=nnt,nct
6493         do j=1,3
6494           gradcorr(j,i)=0.0D0
6495           gradxorr(j,i)=0.0D0
6496         enddo
6497       enddo
6498 C Calculate the dipole-dipole interaction energies
6499       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6500       do i=iatel_s,iatel_e+1
6501         num_conti=num_cont_hb(i)
6502         do jj=1,num_conti
6503           j=jcont_hb(jj,i)
6504 #ifdef MOMENT
6505           call dipole(i,j,jj)
6506 #endif
6507         enddo
6508       enddo
6509       endif
6510 C Calculate the local-electrostatic correlation terms
6511 c                write (iout,*) "gradcorr5 in eello5 before loop"
6512 c                do iii=1,nres
6513 c                  write (iout,'(i5,3f10.5)')
6514 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6515 c                enddo
6516       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6517 c        write (iout,*) "corr loop i",i
6518         i1=i+1
6519         num_conti=num_cont_hb(i)
6520         num_conti1=num_cont_hb(i+1)
6521         do jj=1,num_conti
6522           j=jcont_hb(jj,i)
6523           jp=iabs(j)
6524           do kk=1,num_conti1
6525             j1=jcont_hb(kk,i1)
6526             jp1=iabs(j1)
6527 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6528 c     &         ' jj=',jj,' kk=',kk
6529 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6530             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6531      &          .or. j.lt.0 .and. j1.gt.0) .and.
6532      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6533 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6534 C The system gains extra energy.
6535               n_corr=n_corr+1
6536               sqd1=dsqrt(d_cont(jj,i))
6537               sqd2=dsqrt(d_cont(kk,i1))
6538               sred_geom = sqd1*sqd2
6539               IF (sred_geom.lt.cutoff_corr) THEN
6540                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6541      &            ekont,fprimcont)
6542 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6543 cd     &         ' jj=',jj,' kk=',kk
6544                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6545                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6546                 do l=1,3
6547                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6548                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6549                 enddo
6550                 n_corr1=n_corr1+1
6551 cd               write (iout,*) 'sred_geom=',sred_geom,
6552 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6553 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6554 cd               write (iout,*) "g_contij",g_contij
6555 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6556 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6557                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6558                 if (wcorr4.gt.0.0d0)
6559      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6560                   if (energy_dec.and.wcorr4.gt.0.0d0)
6561      1                 write (iout,'(a6,4i5,0pf7.3)')
6562      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6563 c                write (iout,*) "gradcorr5 before eello5"
6564 c                do iii=1,nres
6565 c                  write (iout,'(i5,3f10.5)')
6566 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6567 c                enddo
6568                 if (wcorr5.gt.0.0d0)
6569      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6570 c                write (iout,*) "gradcorr5 after eello5"
6571 c                do iii=1,nres
6572 c                  write (iout,'(i5,3f10.5)')
6573 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6574 c                enddo
6575                   if (energy_dec.and.wcorr5.gt.0.0d0)
6576      1                 write (iout,'(a6,4i5,0pf7.3)')
6577      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6578 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6579 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6580                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6581      &               .or. wturn6.eq.0.0d0))then
6582 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6583                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6584                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6585      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6586 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6587 cd     &            'ecorr6=',ecorr6
6588 cd                write (iout,'(4e15.5)') sred_geom,
6589 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6590 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6591 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6592                 else if (wturn6.gt.0.0d0
6593      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6594 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6595                   eturn6=eturn6+eello_turn6(i,jj,kk)
6596                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6597      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6598 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6599                 endif
6600               ENDIF
6601 1111          continue
6602             endif
6603           enddo ! kk
6604         enddo ! jj
6605       enddo ! i
6606       do i=1,nres
6607         num_cont_hb(i)=num_cont_hb_old(i)
6608       enddo
6609 c                write (iout,*) "gradcorr5 in eello5"
6610 c                do iii=1,nres
6611 c                  write (iout,'(i5,3f10.5)')
6612 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6613 c                enddo
6614       return
6615       end
6616 c------------------------------------------------------------------------------
6617       subroutine add_hb_contact_eello(ii,jj,itask)
6618       implicit real*8 (a-h,o-z)
6619       include "DIMENSIONS"
6620       include "COMMON.IOUNITS"
6621       integer max_cont
6622       integer max_dim
6623       parameter (max_cont=maxconts)
6624       parameter (max_dim=70)
6625       include "COMMON.CONTACTS"
6626       double precision zapas(max_dim,maxconts,max_fg_procs),
6627      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6628       common /przechowalnia/ zapas
6629       integer i,j,ii,jj,iproc,itask(4),nn
6630 c      write (iout,*) "itask",itask
6631       do i=1,2
6632         iproc=itask(i)
6633         if (iproc.gt.0) then
6634           do j=1,num_cont_hb(ii)
6635             jjc=jcont_hb(j,ii)
6636 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6637             if (jjc.eq.jj) then
6638               ncont_sent(iproc)=ncont_sent(iproc)+1
6639               nn=ncont_sent(iproc)
6640               zapas(1,nn,iproc)=ii
6641               zapas(2,nn,iproc)=jjc
6642               zapas(3,nn,iproc)=d_cont(j,ii)
6643               ind=3
6644               do kk=1,3
6645                 ind=ind+1
6646                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6647               enddo
6648               do kk=1,2
6649                 do ll=1,2
6650                   ind=ind+1
6651                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6652                 enddo
6653               enddo
6654               do jj=1,5
6655                 do kk=1,3
6656                   do ll=1,2
6657                     do mm=1,2
6658                       ind=ind+1
6659                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6660                     enddo
6661                   enddo
6662                 enddo
6663               enddo
6664               exit
6665             endif
6666           enddo
6667         endif
6668       enddo
6669       return
6670       end
6671 c------------------------------------------------------------------------------
6672       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6673       implicit real*8 (a-h,o-z)
6674       include 'DIMENSIONS'
6675       include 'COMMON.IOUNITS'
6676       include 'COMMON.DERIV'
6677       include 'COMMON.INTERACT'
6678       include 'COMMON.CONTACTS'
6679       double precision gx(3),gx1(3)
6680       logical lprn
6681       lprn=.false.
6682       eij=facont_hb(jj,i)
6683       ekl=facont_hb(kk,k)
6684       ees0pij=ees0p(jj,i)
6685       ees0pkl=ees0p(kk,k)
6686       ees0mij=ees0m(jj,i)
6687       ees0mkl=ees0m(kk,k)
6688       ekont=eij*ekl
6689       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6690 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6691 C Following 4 lines for diagnostics.
6692 cd    ees0pkl=0.0D0
6693 cd    ees0pij=1.0D0
6694 cd    ees0mkl=0.0D0
6695 cd    ees0mij=1.0D0
6696 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6697 c     & 'Contacts ',i,j,
6698 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6699 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6700 c     & 'gradcorr_long'
6701 C Calculate the multi-body contribution to energy.
6702 c      ecorr=ecorr+ekont*ees
6703 C Calculate multi-body contributions to the gradient.
6704       coeffpees0pij=coeffp*ees0pij
6705       coeffmees0mij=coeffm*ees0mij
6706       coeffpees0pkl=coeffp*ees0pkl
6707       coeffmees0mkl=coeffm*ees0mkl
6708       do ll=1,3
6709 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6710         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6711      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6712      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6713         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6714      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6715      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6716 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6717         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6718      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6719      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6720         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6721      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6722      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6723         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6724      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6725      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6726         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6727         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6728         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6729      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6730      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6731         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6732         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6733 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6734       enddo
6735 c      write (iout,*)
6736 cgrad      do m=i+1,j-1
6737 cgrad        do ll=1,3
6738 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6739 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6740 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6741 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6742 cgrad        enddo
6743 cgrad      enddo
6744 cgrad      do m=k+1,l-1
6745 cgrad        do ll=1,3
6746 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6747 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6748 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6749 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6750 cgrad        enddo
6751 cgrad      enddo
6752 c      write (iout,*) "ehbcorr",ekont*ees
6753       ehbcorr=ekont*ees
6754       return
6755       end
6756 #ifdef MOMENT
6757 C---------------------------------------------------------------------------
6758       subroutine dipole(i,j,jj)
6759       implicit real*8 (a-h,o-z)
6760       include 'DIMENSIONS'
6761       include 'COMMON.IOUNITS'
6762       include 'COMMON.CHAIN'
6763       include 'COMMON.FFIELD'
6764       include 'COMMON.DERIV'
6765       include 'COMMON.INTERACT'
6766       include 'COMMON.CONTACTS'
6767       include 'COMMON.TORSION'
6768       include 'COMMON.VAR'
6769       include 'COMMON.GEO'
6770       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6771      &  auxmat(2,2)
6772       iti1 = itortyp(itype(i+1))
6773       if (j.lt.nres-1) then
6774         itj1 = itortyp(itype(j+1))
6775       else
6776         itj1=ntortyp+1
6777       endif
6778       do iii=1,2
6779         dipi(iii,1)=Ub2(iii,i)
6780         dipderi(iii)=Ub2der(iii,i)
6781         dipi(iii,2)=b1(iii,iti1)
6782         dipj(iii,1)=Ub2(iii,j)
6783         dipderj(iii)=Ub2der(iii,j)
6784         dipj(iii,2)=b1(iii,itj1)
6785       enddo
6786       kkk=0
6787       do iii=1,2
6788         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6789         do jjj=1,2
6790           kkk=kkk+1
6791           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6792         enddo
6793       enddo
6794       do kkk=1,5
6795         do lll=1,3
6796           mmm=0
6797           do iii=1,2
6798             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6799      &        auxvec(1))
6800             do jjj=1,2
6801               mmm=mmm+1
6802               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6803             enddo
6804           enddo
6805         enddo
6806       enddo
6807       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6808       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6809       do iii=1,2
6810         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6811       enddo
6812       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6813       do iii=1,2
6814         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6815       enddo
6816       return
6817       end
6818 #endif
6819 C---------------------------------------------------------------------------
6820       subroutine calc_eello(i,j,k,l,jj,kk)
6821 C
6822 C This subroutine computes matrices and vectors needed to calculate
6823 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6824 C
6825       implicit real*8 (a-h,o-z)
6826       include 'DIMENSIONS'
6827       include 'COMMON.IOUNITS'
6828       include 'COMMON.CHAIN'
6829       include 'COMMON.DERIV'
6830       include 'COMMON.INTERACT'
6831       include 'COMMON.CONTACTS'
6832       include 'COMMON.TORSION'
6833       include 'COMMON.VAR'
6834       include 'COMMON.GEO'
6835       include 'COMMON.FFIELD'
6836       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6837      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6838       logical lprn
6839       common /kutas/ lprn
6840 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6841 cd     & ' jj=',jj,' kk=',kk
6842 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6843 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6844 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6845       do iii=1,2
6846         do jjj=1,2
6847           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6848           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6849         enddo
6850       enddo
6851       call transpose2(aa1(1,1),aa1t(1,1))
6852       call transpose2(aa2(1,1),aa2t(1,1))
6853       do kkk=1,5
6854         do lll=1,3
6855           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6856      &      aa1tder(1,1,lll,kkk))
6857           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6858      &      aa2tder(1,1,lll,kkk))
6859         enddo
6860       enddo
6861       if (l.eq.j+1) then
6862 C parallel orientation of the two CA-CA-CA frames.
6863         if (i.gt.1) then
6864           iti=itortyp(itype(i))
6865         else
6866           iti=ntortyp+1
6867         endif
6868         itk1=itortyp(itype(k+1))
6869         itj=itortyp(itype(j))
6870         if (l.lt.nres-1) then
6871           itl1=itortyp(itype(l+1))
6872         else
6873           itl1=ntortyp+1
6874         endif
6875 C A1 kernel(j+1) A2T
6876 cd        do iii=1,2
6877 cd          write (iout,'(3f10.5,5x,3f10.5)')
6878 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6879 cd        enddo
6880         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6881      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6882      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6883 C Following matrices are needed only for 6-th order cumulants
6884         IF (wcorr6.gt.0.0d0) THEN
6885         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6886      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6887      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6888         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6889      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6890      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6891      &   ADtEAderx(1,1,1,1,1,1))
6892         lprn=.false.
6893         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6894      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6895      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6896      &   ADtEA1derx(1,1,1,1,1,1))
6897         ENDIF
6898 C End 6-th order cumulants
6899 cd        lprn=.false.
6900 cd        if (lprn) then
6901 cd        write (2,*) 'In calc_eello6'
6902 cd        do iii=1,2
6903 cd          write (2,*) 'iii=',iii
6904 cd          do kkk=1,5
6905 cd            write (2,*) 'kkk=',kkk
6906 cd            do jjj=1,2
6907 cd              write (2,'(3(2f10.5),5x)')
6908 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6909 cd            enddo
6910 cd          enddo
6911 cd        enddo
6912 cd        endif
6913         call transpose2(EUgder(1,1,k),auxmat(1,1))
6914         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6915         call transpose2(EUg(1,1,k),auxmat(1,1))
6916         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6917         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6918         do iii=1,2
6919           do kkk=1,5
6920             do lll=1,3
6921               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6922      &          EAEAderx(1,1,lll,kkk,iii,1))
6923             enddo
6924           enddo
6925         enddo
6926 C A1T kernel(i+1) A2
6927         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6928      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6929      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6930 C Following matrices are needed only for 6-th order cumulants
6931         IF (wcorr6.gt.0.0d0) THEN
6932         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6933      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6934      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6935         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6936      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6937      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6938      &   ADtEAderx(1,1,1,1,1,2))
6939         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6940      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6941      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6942      &   ADtEA1derx(1,1,1,1,1,2))
6943         ENDIF
6944 C End 6-th order cumulants
6945         call transpose2(EUgder(1,1,l),auxmat(1,1))
6946         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6947         call transpose2(EUg(1,1,l),auxmat(1,1))
6948         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6949         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6950         do iii=1,2
6951           do kkk=1,5
6952             do lll=1,3
6953               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6954      &          EAEAderx(1,1,lll,kkk,iii,2))
6955             enddo
6956           enddo
6957         enddo
6958 C AEAb1 and AEAb2
6959 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6960 C They are needed only when the fifth- or the sixth-order cumulants are
6961 C indluded.
6962         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6963         call transpose2(AEA(1,1,1),auxmat(1,1))
6964         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6965         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6966         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6967         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6968         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6969         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6970         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6971         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6972         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6973         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6974         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6975         call transpose2(AEA(1,1,2),auxmat(1,1))
6976         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6977         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6978         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6979         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6980         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6981         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6982         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6983         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6984         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6985         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6986         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6987 C Calculate the Cartesian derivatives of the vectors.
6988         do iii=1,2
6989           do kkk=1,5
6990             do lll=1,3
6991               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6992               call matvec2(auxmat(1,1),b1(1,iti),
6993      &          AEAb1derx(1,lll,kkk,iii,1,1))
6994               call matvec2(auxmat(1,1),Ub2(1,i),
6995      &          AEAb2derx(1,lll,kkk,iii,1,1))
6996               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6997      &          AEAb1derx(1,lll,kkk,iii,2,1))
6998               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6999      &          AEAb2derx(1,lll,kkk,iii,2,1))
7000               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7001               call matvec2(auxmat(1,1),b1(1,itj),
7002      &          AEAb1derx(1,lll,kkk,iii,1,2))
7003               call matvec2(auxmat(1,1),Ub2(1,j),
7004      &          AEAb2derx(1,lll,kkk,iii,1,2))
7005               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7006      &          AEAb1derx(1,lll,kkk,iii,2,2))
7007               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7008      &          AEAb2derx(1,lll,kkk,iii,2,2))
7009             enddo
7010           enddo
7011         enddo
7012         ENDIF
7013 C End vectors
7014       else
7015 C Antiparallel orientation of the two CA-CA-CA frames.
7016         if (i.gt.1) then
7017           iti=itortyp(itype(i))
7018         else
7019           iti=ntortyp+1
7020         endif
7021         itk1=itortyp(itype(k+1))
7022         itl=itortyp(itype(l))
7023         itj=itortyp(itype(j))
7024         if (j.lt.nres-1) then
7025           itj1=itortyp(itype(j+1))
7026         else
7027           itj1=ntortyp+1
7028         endif
7029 C A2 kernel(j-1)T A1T
7030         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7031      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7032      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7033 C Following matrices are needed only for 6-th order cumulants
7034         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7035      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7036         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7037      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7038      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7039         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7040      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7041      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7042      &   ADtEAderx(1,1,1,1,1,1))
7043         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7044      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7045      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7046      &   ADtEA1derx(1,1,1,1,1,1))
7047         ENDIF
7048 C End 6-th order cumulants
7049         call transpose2(EUgder(1,1,k),auxmat(1,1))
7050         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7051         call transpose2(EUg(1,1,k),auxmat(1,1))
7052         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7053         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7054         do iii=1,2
7055           do kkk=1,5
7056             do lll=1,3
7057               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7058      &          EAEAderx(1,1,lll,kkk,iii,1))
7059             enddo
7060           enddo
7061         enddo
7062 C A2T kernel(i+1)T A1
7063         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7064      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7065      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7066 C Following matrices are needed only for 6-th order cumulants
7067         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7068      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7069         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7070      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7071      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7072         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7073      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7074      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7075      &   ADtEAderx(1,1,1,1,1,2))
7076         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7077      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7078      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7079      &   ADtEA1derx(1,1,1,1,1,2))
7080         ENDIF
7081 C End 6-th order cumulants
7082         call transpose2(EUgder(1,1,j),auxmat(1,1))
7083         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7084         call transpose2(EUg(1,1,j),auxmat(1,1))
7085         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7086         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7087         do iii=1,2
7088           do kkk=1,5
7089             do lll=1,3
7090               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7091      &          EAEAderx(1,1,lll,kkk,iii,2))
7092             enddo
7093           enddo
7094         enddo
7095 C AEAb1 and AEAb2
7096 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7097 C They are needed only when the fifth- or the sixth-order cumulants are
7098 C indluded.
7099         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7100      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7101         call transpose2(AEA(1,1,1),auxmat(1,1))
7102         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7103         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7104         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7105         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7106         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7107         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7108         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7109         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7110         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7111         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7112         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7113         call transpose2(AEA(1,1,2),auxmat(1,1))
7114         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7115         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7116         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7117         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7118         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7119         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7120         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7121         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7122         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7123         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7124         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7125 C Calculate the Cartesian derivatives of the vectors.
7126         do iii=1,2
7127           do kkk=1,5
7128             do lll=1,3
7129               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7130               call matvec2(auxmat(1,1),b1(1,iti),
7131      &          AEAb1derx(1,lll,kkk,iii,1,1))
7132               call matvec2(auxmat(1,1),Ub2(1,i),
7133      &          AEAb2derx(1,lll,kkk,iii,1,1))
7134               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7135      &          AEAb1derx(1,lll,kkk,iii,2,1))
7136               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7137      &          AEAb2derx(1,lll,kkk,iii,2,1))
7138               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7139               call matvec2(auxmat(1,1),b1(1,itl),
7140      &          AEAb1derx(1,lll,kkk,iii,1,2))
7141               call matvec2(auxmat(1,1),Ub2(1,l),
7142      &          AEAb2derx(1,lll,kkk,iii,1,2))
7143               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7144      &          AEAb1derx(1,lll,kkk,iii,2,2))
7145               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7146      &          AEAb2derx(1,lll,kkk,iii,2,2))
7147             enddo
7148           enddo
7149         enddo
7150         ENDIF
7151 C End vectors
7152       endif
7153       return
7154       end
7155 C---------------------------------------------------------------------------
7156       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7157      &  KK,KKderg,AKA,AKAderg,AKAderx)
7158       implicit none
7159       integer nderg
7160       logical transp
7161       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7162      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7163      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7164       integer iii,kkk,lll
7165       integer jjj,mmm
7166       logical lprn
7167       common /kutas/ lprn
7168       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7169       do iii=1,nderg
7170         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7171      &    AKAderg(1,1,iii))
7172       enddo
7173 cd      if (lprn) write (2,*) 'In kernel'
7174       do kkk=1,5
7175 cd        if (lprn) write (2,*) 'kkk=',kkk
7176         do lll=1,3
7177           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7178      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7179 cd          if (lprn) then
7180 cd            write (2,*) 'lll=',lll
7181 cd            write (2,*) 'iii=1'
7182 cd            do jjj=1,2
7183 cd              write (2,'(3(2f10.5),5x)')
7184 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7185 cd            enddo
7186 cd          endif
7187           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7188      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7189 cd          if (lprn) then
7190 cd            write (2,*) 'lll=',lll
7191 cd            write (2,*) 'iii=2'
7192 cd            do jjj=1,2
7193 cd              write (2,'(3(2f10.5),5x)')
7194 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7195 cd            enddo
7196 cd          endif
7197         enddo
7198       enddo
7199       return
7200       end
7201 C---------------------------------------------------------------------------
7202       double precision function eello4(i,j,k,l,jj,kk)
7203       implicit real*8 (a-h,o-z)
7204       include 'DIMENSIONS'
7205       include 'COMMON.IOUNITS'
7206       include 'COMMON.CHAIN'
7207       include 'COMMON.DERIV'
7208       include 'COMMON.INTERACT'
7209       include 'COMMON.CONTACTS'
7210       include 'COMMON.TORSION'
7211       include 'COMMON.VAR'
7212       include 'COMMON.GEO'
7213       double precision pizda(2,2),ggg1(3),ggg2(3)
7214 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7215 cd        eello4=0.0d0
7216 cd        return
7217 cd      endif
7218 cd      print *,'eello4:',i,j,k,l,jj,kk
7219 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7220 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7221 cold      eij=facont_hb(jj,i)
7222 cold      ekl=facont_hb(kk,k)
7223 cold      ekont=eij*ekl
7224       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7225 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7226       gcorr_loc(k-1)=gcorr_loc(k-1)
7227      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7228       if (l.eq.j+1) then
7229         gcorr_loc(l-1)=gcorr_loc(l-1)
7230      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7231       else
7232         gcorr_loc(j-1)=gcorr_loc(j-1)
7233      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7234       endif
7235       do iii=1,2
7236         do kkk=1,5
7237           do lll=1,3
7238             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7239      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7240 cd            derx(lll,kkk,iii)=0.0d0
7241           enddo
7242         enddo
7243       enddo
7244 cd      gcorr_loc(l-1)=0.0d0
7245 cd      gcorr_loc(j-1)=0.0d0
7246 cd      gcorr_loc(k-1)=0.0d0
7247 cd      eel4=1.0d0
7248 cd      write (iout,*)'Contacts have occurred for peptide groups',
7249 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7250 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7251       if (j.lt.nres-1) then
7252         j1=j+1
7253         j2=j-1
7254       else
7255         j1=j-1
7256         j2=j-2
7257       endif
7258       if (l.lt.nres-1) then
7259         l1=l+1
7260         l2=l-1
7261       else
7262         l1=l-1
7263         l2=l-2
7264       endif
7265       do ll=1,3
7266 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7267 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7268         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7269         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7270 cgrad        ghalf=0.5d0*ggg1(ll)
7271         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7272         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7273         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7274         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7275         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7276         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7277 cgrad        ghalf=0.5d0*ggg2(ll)
7278         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7279         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7280         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7281         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7282         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7283         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7284       enddo
7285 cgrad      do m=i+1,j-1
7286 cgrad        do ll=1,3
7287 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7288 cgrad        enddo
7289 cgrad      enddo
7290 cgrad      do m=k+1,l-1
7291 cgrad        do ll=1,3
7292 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7293 cgrad        enddo
7294 cgrad      enddo
7295 cgrad      do m=i+2,j2
7296 cgrad        do ll=1,3
7297 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7298 cgrad        enddo
7299 cgrad      enddo
7300 cgrad      do m=k+2,l2
7301 cgrad        do ll=1,3
7302 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7303 cgrad        enddo
7304 cgrad      enddo
7305 cd      do iii=1,nres-3
7306 cd        write (2,*) iii,gcorr_loc(iii)
7307 cd      enddo
7308       eello4=ekont*eel4
7309 cd      write (2,*) 'ekont',ekont
7310 cd      write (iout,*) 'eello4',ekont*eel4
7311       return
7312       end
7313 C---------------------------------------------------------------------------
7314       double precision function eello5(i,j,k,l,jj,kk)
7315       implicit real*8 (a-h,o-z)
7316       include 'DIMENSIONS'
7317       include 'COMMON.IOUNITS'
7318       include 'COMMON.CHAIN'
7319       include 'COMMON.DERIV'
7320       include 'COMMON.INTERACT'
7321       include 'COMMON.CONTACTS'
7322       include 'COMMON.TORSION'
7323       include 'COMMON.VAR'
7324       include 'COMMON.GEO'
7325       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7326       double precision ggg1(3),ggg2(3)
7327 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7328 C                                                                              C
7329 C                            Parallel chains                                   C
7330 C                                                                              C
7331 C          o             o                   o             o                   C
7332 C         /l\           / \             \   / \           / \   /              C
7333 C        /   \         /   \             \ /   \         /   \ /               C
7334 C       j| o |l1       | o |              o| o |         | o |o                C
7335 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7336 C      \i/   \         /   \ /             /   \         /   \                 C
7337 C       o    k1             o                                                  C
7338 C         (I)          (II)                (III)          (IV)                 C
7339 C                                                                              C
7340 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7341 C                                                                              C
7342 C                            Antiparallel chains                               C
7343 C                                                                              C
7344 C          o             o                   o             o                   C
7345 C         /j\           / \             \   / \           / \   /              C
7346 C        /   \         /   \             \ /   \         /   \ /               C
7347 C      j1| o |l        | o |              o| o |         | o |o                C
7348 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7349 C      \i/   \         /   \ /             /   \         /   \                 C
7350 C       o     k1            o                                                  C
7351 C         (I)          (II)                (III)          (IV)                 C
7352 C                                                                              C
7353 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7354 C                                                                              C
7355 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7356 C                                                                              C
7357 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7358 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7359 cd        eello5=0.0d0
7360 cd        return
7361 cd      endif
7362 cd      write (iout,*)
7363 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7364 cd     &   ' and',k,l
7365       itk=itortyp(itype(k))
7366       itl=itortyp(itype(l))
7367       itj=itortyp(itype(j))
7368       eello5_1=0.0d0
7369       eello5_2=0.0d0
7370       eello5_3=0.0d0
7371       eello5_4=0.0d0
7372 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7373 cd     &   eel5_3_num,eel5_4_num)
7374       do iii=1,2
7375         do kkk=1,5
7376           do lll=1,3
7377             derx(lll,kkk,iii)=0.0d0
7378           enddo
7379         enddo
7380       enddo
7381 cd      eij=facont_hb(jj,i)
7382 cd      ekl=facont_hb(kk,k)
7383 cd      ekont=eij*ekl
7384 cd      write (iout,*)'Contacts have occurred for peptide groups',
7385 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7386 cd      goto 1111
7387 C Contribution from the graph I.
7388 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7389 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7390       call transpose2(EUg(1,1,k),auxmat(1,1))
7391       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7392       vv(1)=pizda(1,1)-pizda(2,2)
7393       vv(2)=pizda(1,2)+pizda(2,1)
7394       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7395      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7396 C Explicit gradient in virtual-dihedral angles.
7397       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7398      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7399      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7400       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7401       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7402       vv(1)=pizda(1,1)-pizda(2,2)
7403       vv(2)=pizda(1,2)+pizda(2,1)
7404       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7405      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7406      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7407       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7408       vv(1)=pizda(1,1)-pizda(2,2)
7409       vv(2)=pizda(1,2)+pizda(2,1)
7410       if (l.eq.j+1) then
7411         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7412      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7413      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7414       else
7415         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7416      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7417      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7418       endif
7419 C Cartesian gradient
7420       do iii=1,2
7421         do kkk=1,5
7422           do lll=1,3
7423             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7424      &        pizda(1,1))
7425             vv(1)=pizda(1,1)-pizda(2,2)
7426             vv(2)=pizda(1,2)+pizda(2,1)
7427             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7428      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7429      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7430           enddo
7431         enddo
7432       enddo
7433 c      goto 1112
7434 c1111  continue
7435 C Contribution from graph II
7436       call transpose2(EE(1,1,itk),auxmat(1,1))
7437       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7438       vv(1)=pizda(1,1)+pizda(2,2)
7439       vv(2)=pizda(2,1)-pizda(1,2)
7440       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7441      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7442 C Explicit gradient in virtual-dihedral angles.
7443       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7444      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7445       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7446       vv(1)=pizda(1,1)+pizda(2,2)
7447       vv(2)=pizda(2,1)-pizda(1,2)
7448       if (l.eq.j+1) then
7449         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7450      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7451      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7452       else
7453         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7454      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7455      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7456       endif
7457 C Cartesian gradient
7458       do iii=1,2
7459         do kkk=1,5
7460           do lll=1,3
7461             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7462      &        pizda(1,1))
7463             vv(1)=pizda(1,1)+pizda(2,2)
7464             vv(2)=pizda(2,1)-pizda(1,2)
7465             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7466      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7467      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7468           enddo
7469         enddo
7470       enddo
7471 cd      goto 1112
7472 cd1111  continue
7473       if (l.eq.j+1) then
7474 cd        goto 1110
7475 C Parallel orientation
7476 C Contribution from graph III
7477         call transpose2(EUg(1,1,l),auxmat(1,1))
7478         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7479         vv(1)=pizda(1,1)-pizda(2,2)
7480         vv(2)=pizda(1,2)+pizda(2,1)
7481         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7483 C Explicit gradient in virtual-dihedral angles.
7484         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7485      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7486      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7487         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7488         vv(1)=pizda(1,1)-pizda(2,2)
7489         vv(2)=pizda(1,2)+pizda(2,1)
7490         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7491      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7492      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7493         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7494         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7495         vv(1)=pizda(1,1)-pizda(2,2)
7496         vv(2)=pizda(1,2)+pizda(2,1)
7497         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7498      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7499      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7500 C Cartesian gradient
7501         do iii=1,2
7502           do kkk=1,5
7503             do lll=1,3
7504               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7505      &          pizda(1,1))
7506               vv(1)=pizda(1,1)-pizda(2,2)
7507               vv(2)=pizda(1,2)+pizda(2,1)
7508               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7509      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7510      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7511             enddo
7512           enddo
7513         enddo
7514 cd        goto 1112
7515 C Contribution from graph IV
7516 cd1110    continue
7517         call transpose2(EE(1,1,itl),auxmat(1,1))
7518         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7519         vv(1)=pizda(1,1)+pizda(2,2)
7520         vv(2)=pizda(2,1)-pizda(1,2)
7521         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7522      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7523 C Explicit gradient in virtual-dihedral angles.
7524         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7525      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7526         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7527         vv(1)=pizda(1,1)+pizda(2,2)
7528         vv(2)=pizda(2,1)-pizda(1,2)
7529         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7530      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7531      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7532 C Cartesian gradient
7533         do iii=1,2
7534           do kkk=1,5
7535             do lll=1,3
7536               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7537      &          pizda(1,1))
7538               vv(1)=pizda(1,1)+pizda(2,2)
7539               vv(2)=pizda(2,1)-pizda(1,2)
7540               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7541      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7542      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7543             enddo
7544           enddo
7545         enddo
7546       else
7547 C Antiparallel orientation
7548 C Contribution from graph III
7549 c        goto 1110
7550         call transpose2(EUg(1,1,j),auxmat(1,1))
7551         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7552         vv(1)=pizda(1,1)-pizda(2,2)
7553         vv(2)=pizda(1,2)+pizda(2,1)
7554         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7555      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7556 C Explicit gradient in virtual-dihedral angles.
7557         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7558      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7559      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7560         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7561         vv(1)=pizda(1,1)-pizda(2,2)
7562         vv(2)=pizda(1,2)+pizda(2,1)
7563         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7564      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7565      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7566         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7567         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7568         vv(1)=pizda(1,1)-pizda(2,2)
7569         vv(2)=pizda(1,2)+pizda(2,1)
7570         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7571      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7572      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7573 C Cartesian gradient
7574         do iii=1,2
7575           do kkk=1,5
7576             do lll=1,3
7577               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7578      &          pizda(1,1))
7579               vv(1)=pizda(1,1)-pizda(2,2)
7580               vv(2)=pizda(1,2)+pizda(2,1)
7581               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7582      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7583      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7584             enddo
7585           enddo
7586         enddo
7587 cd        goto 1112
7588 C Contribution from graph IV
7589 1110    continue
7590         call transpose2(EE(1,1,itj),auxmat(1,1))
7591         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7592         vv(1)=pizda(1,1)+pizda(2,2)
7593         vv(2)=pizda(2,1)-pizda(1,2)
7594         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7595      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7596 C Explicit gradient in virtual-dihedral angles.
7597         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7598      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7599         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7600         vv(1)=pizda(1,1)+pizda(2,2)
7601         vv(2)=pizda(2,1)-pizda(1,2)
7602         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7603      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7604      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7605 C Cartesian gradient
7606         do iii=1,2
7607           do kkk=1,5
7608             do lll=1,3
7609               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7610      &          pizda(1,1))
7611               vv(1)=pizda(1,1)+pizda(2,2)
7612               vv(2)=pizda(2,1)-pizda(1,2)
7613               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7614      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7615      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7616             enddo
7617           enddo
7618         enddo
7619       endif
7620 1112  continue
7621       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7622 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7623 cd        write (2,*) 'ijkl',i,j,k,l
7624 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7625 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7626 cd      endif
7627 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7628 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7629 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7630 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7631       if (j.lt.nres-1) then
7632         j1=j+1
7633         j2=j-1
7634       else
7635         j1=j-1
7636         j2=j-2
7637       endif
7638       if (l.lt.nres-1) then
7639         l1=l+1
7640         l2=l-1
7641       else
7642         l1=l-1
7643         l2=l-2
7644       endif
7645 cd      eij=1.0d0
7646 cd      ekl=1.0d0
7647 cd      ekont=1.0d0
7648 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7649 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7650 C        summed up outside the subrouine as for the other subroutines
7651 C        handling long-range interactions. The old code is commented out
7652 C        with "cgrad" to keep track of changes.
7653       do ll=1,3
7654 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7655 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7656         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7657         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7658 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7659 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7660 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7661 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7662 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7663 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7664 c     &   gradcorr5ij,
7665 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7666 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7667 cgrad        ghalf=0.5d0*ggg1(ll)
7668 cd        ghalf=0.0d0
7669         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7670         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7671         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7672         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7673         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7674         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7675 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7676 cgrad        ghalf=0.5d0*ggg2(ll)
7677 cd        ghalf=0.0d0
7678         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7679         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7680         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7681         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7682         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7683         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7684       enddo
7685 cd      goto 1112
7686 cgrad      do m=i+1,j-1
7687 cgrad        do ll=1,3
7688 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7689 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7690 cgrad        enddo
7691 cgrad      enddo
7692 cgrad      do m=k+1,l-1
7693 cgrad        do ll=1,3
7694 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7695 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7696 cgrad        enddo
7697 cgrad      enddo
7698 c1112  continue
7699 cgrad      do m=i+2,j2
7700 cgrad        do ll=1,3
7701 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7702 cgrad        enddo
7703 cgrad      enddo
7704 cgrad      do m=k+2,l2
7705 cgrad        do ll=1,3
7706 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7707 cgrad        enddo
7708 cgrad      enddo
7709 cd      do iii=1,nres-3
7710 cd        write (2,*) iii,g_corr5_loc(iii)
7711 cd      enddo
7712       eello5=ekont*eel5
7713 cd      write (2,*) 'ekont',ekont
7714 cd      write (iout,*) 'eello5',ekont*eel5
7715       return
7716       end
7717 c--------------------------------------------------------------------------
7718       double precision function eello6(i,j,k,l,jj,kk)
7719       implicit real*8 (a-h,o-z)
7720       include 'DIMENSIONS'
7721       include 'COMMON.IOUNITS'
7722       include 'COMMON.CHAIN'
7723       include 'COMMON.DERIV'
7724       include 'COMMON.INTERACT'
7725       include 'COMMON.CONTACTS'
7726       include 'COMMON.TORSION'
7727       include 'COMMON.VAR'
7728       include 'COMMON.GEO'
7729       include 'COMMON.FFIELD'
7730       double precision ggg1(3),ggg2(3)
7731 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7732 cd        eello6=0.0d0
7733 cd        return
7734 cd      endif
7735 cd      write (iout,*)
7736 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7737 cd     &   ' and',k,l
7738       eello6_1=0.0d0
7739       eello6_2=0.0d0
7740       eello6_3=0.0d0
7741       eello6_4=0.0d0
7742       eello6_5=0.0d0
7743       eello6_6=0.0d0
7744 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7745 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7746       do iii=1,2
7747         do kkk=1,5
7748           do lll=1,3
7749             derx(lll,kkk,iii)=0.0d0
7750           enddo
7751         enddo
7752       enddo
7753 cd      eij=facont_hb(jj,i)
7754 cd      ekl=facont_hb(kk,k)
7755 cd      ekont=eij*ekl
7756 cd      eij=1.0d0
7757 cd      ekl=1.0d0
7758 cd      ekont=1.0d0
7759       if (l.eq.j+1) then
7760         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7761         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7762         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7763         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7764         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7765         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7766       else
7767         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7768         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7769         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7770         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7771         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7772           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7773         else
7774           eello6_5=0.0d0
7775         endif
7776         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7777       endif
7778 C If turn contributions are considered, they will be handled separately.
7779       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7780 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7781 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7782 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7783 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7784 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7785 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7786 cd      goto 1112
7787       if (j.lt.nres-1) then
7788         j1=j+1
7789         j2=j-1
7790       else
7791         j1=j-1
7792         j2=j-2
7793       endif
7794       if (l.lt.nres-1) then
7795         l1=l+1
7796         l2=l-1
7797       else
7798         l1=l-1
7799         l2=l-2
7800       endif
7801       do ll=1,3
7802 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7803 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7804 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7805 cgrad        ghalf=0.5d0*ggg1(ll)
7806 cd        ghalf=0.0d0
7807         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7808         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7809         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7810         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7811         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7812         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7813         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7814         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7815 cgrad        ghalf=0.5d0*ggg2(ll)
7816 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7817 cd        ghalf=0.0d0
7818         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7819         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7820         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7821         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7822         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7823         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7824       enddo
7825 cd      goto 1112
7826 cgrad      do m=i+1,j-1
7827 cgrad        do ll=1,3
7828 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7829 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7830 cgrad        enddo
7831 cgrad      enddo
7832 cgrad      do m=k+1,l-1
7833 cgrad        do ll=1,3
7834 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7835 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7836 cgrad        enddo
7837 cgrad      enddo
7838 cgrad1112  continue
7839 cgrad      do m=i+2,j2
7840 cgrad        do ll=1,3
7841 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7842 cgrad        enddo
7843 cgrad      enddo
7844 cgrad      do m=k+2,l2
7845 cgrad        do ll=1,3
7846 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7847 cgrad        enddo
7848 cgrad      enddo
7849 cd      do iii=1,nres-3
7850 cd        write (2,*) iii,g_corr6_loc(iii)
7851 cd      enddo
7852       eello6=ekont*eel6
7853 cd      write (2,*) 'ekont',ekont
7854 cd      write (iout,*) 'eello6',ekont*eel6
7855       return
7856       end
7857 c--------------------------------------------------------------------------
7858       double precision function eello6_graph1(i,j,k,l,imat,swap)
7859       implicit real*8 (a-h,o-z)
7860       include 'DIMENSIONS'
7861       include 'COMMON.IOUNITS'
7862       include 'COMMON.CHAIN'
7863       include 'COMMON.DERIV'
7864       include 'COMMON.INTERACT'
7865       include 'COMMON.CONTACTS'
7866       include 'COMMON.TORSION'
7867       include 'COMMON.VAR'
7868       include 'COMMON.GEO'
7869       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7870       logical swap
7871       logical lprn
7872       common /kutas/ lprn
7873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7874 C                                                                              C
7875 C      Parallel       Antiparallel                                             C
7876 C                                                                              C
7877 C          o             o                                                     C
7878 C         /l\           /j\                                                    C
7879 C        /   \         /   \                                                   C
7880 C       /| o |         | o |\                                                  C
7881 C     \ j|/k\|  /   \  |/k\|l /                                                C
7882 C      \ /   \ /     \ /   \ /                                                 C
7883 C       o     o       o     o                                                  C
7884 C       i             i                                                        C
7885 C                                                                              C
7886 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7887       itk=itortyp(itype(k))
7888       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7889       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7890       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7891       call transpose2(EUgC(1,1,k),auxmat(1,1))
7892       call matmat2(AEA(1,1,imat),auxmat(1,1),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)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7897       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7898       s5=scalar2(vv(1),Dtobr2(1,i))
7899 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7900       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7901       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7902      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7903      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7904      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7905      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7906      & +scalar2(vv(1),Dtobr2der(1,i)))
7907       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7908       vv1(1)=pizda1(1,1)-pizda1(2,2)
7909       vv1(2)=pizda1(1,2)+pizda1(2,1)
7910       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7911       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7912       if (l.eq.j+1) then
7913         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7914      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7915      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7916      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7917      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7918       else
7919         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7920      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7921      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7922      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7923      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7924       endif
7925       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7926       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7927       vv1(1)=pizda1(1,1)-pizda1(2,2)
7928       vv1(2)=pizda1(1,2)+pizda1(2,1)
7929       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7930      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7931      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7932      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7933       do iii=1,2
7934         if (swap) then
7935           ind=3-iii
7936         else
7937           ind=iii
7938         endif
7939         do kkk=1,5
7940           do lll=1,3
7941             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7942             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7943             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7944             call transpose2(EUgC(1,1,k),auxmat(1,1))
7945             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7946      &        pizda1(1,1))
7947             vv1(1)=pizda1(1,1)-pizda1(2,2)
7948             vv1(2)=pizda1(1,2)+pizda1(2,1)
7949             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7950             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7951      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7952             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7953      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7954             s5=scalar2(vv(1),Dtobr2(1,i))
7955             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7956           enddo
7957         enddo
7958       enddo
7959       return
7960       end
7961 c----------------------------------------------------------------------------
7962       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7963       implicit real*8 (a-h,o-z)
7964       include 'DIMENSIONS'
7965       include 'COMMON.IOUNITS'
7966       include 'COMMON.CHAIN'
7967       include 'COMMON.DERIV'
7968       include 'COMMON.INTERACT'
7969       include 'COMMON.CONTACTS'
7970       include 'COMMON.TORSION'
7971       include 'COMMON.VAR'
7972       include 'COMMON.GEO'
7973       logical swap
7974       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7975      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7976       logical lprn
7977       common /kutas/ lprn
7978 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7979 C                                                                              C
7980 C      Parallel       Antiparallel                                             C
7981 C                                                                              C
7982 C          o             o                                                     C
7983 C     \   /l\           /j\   /                                                C
7984 C      \ /   \         /   \ /                                                 C
7985 C       o| o |         | o |o                                                  C
7986 C     \ j|/k\|      \  |/k\|l                                                  C
7987 C      \ /   \       \ /   \                                                   C
7988 C       o             o                                                        C
7989 C       i             i                                                        C
7990 C                                                                              C
7991 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7992 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7993 C AL 7/4/01 s1 would occur in the sixth-order moment,
7994 C           but not in a cluster cumulant
7995 #ifdef MOMENT
7996       s1=dip(1,jj,i)*dip(1,kk,k)
7997 #endif
7998       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7999       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8000       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8001       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8002       call transpose2(EUg(1,1,k),auxmat(1,1))
8003       call matmat2(ADtEA1(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 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8008 #ifdef MOMENT
8009       eello6_graph2=-(s1+s2+s3+s4)
8010 #else
8011       eello6_graph2=-(s2+s3+s4)
8012 #endif
8013 c      eello6_graph2=-s3
8014 C Derivatives in gamma(i-1)
8015       if (i.gt.1) then
8016 #ifdef MOMENT
8017         s1=dipderg(1,jj,i)*dip(1,kk,k)
8018 #endif
8019         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8020         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8021         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8022         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8023 #ifdef MOMENT
8024         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8025 #else
8026         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8027 #endif
8028 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8029       endif
8030 C Derivatives in gamma(k-1)
8031 #ifdef MOMENT
8032       s1=dip(1,jj,i)*dipderg(1,kk,k)
8033 #endif
8034       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8035       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8036       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8037       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8038       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8039       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8040       vv(1)=pizda(1,1)-pizda(2,2)
8041       vv(2)=pizda(1,2)+pizda(2,1)
8042       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8043 #ifdef MOMENT
8044       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8045 #else
8046       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8047 #endif
8048 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8049 C Derivatives in gamma(j-1) or gamma(l-1)
8050       if (j.gt.1) then
8051 #ifdef MOMENT
8052         s1=dipderg(3,jj,i)*dip(1,kk,k)
8053 #endif
8054         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8055         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8056         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8057         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8058         vv(1)=pizda(1,1)-pizda(2,2)
8059         vv(2)=pizda(1,2)+pizda(2,1)
8060         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8061 #ifdef MOMENT
8062         if (swap) then
8063           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8064         else
8065           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8066         endif
8067 #endif
8068         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8069 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8070       endif
8071 C Derivatives in gamma(l-1) or gamma(j-1)
8072       if (l.gt.1) then
8073 #ifdef MOMENT
8074         s1=dip(1,jj,i)*dipderg(3,kk,k)
8075 #endif
8076         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8077         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8078         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8079         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8080         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8081         vv(1)=pizda(1,1)-pizda(2,2)
8082         vv(2)=pizda(1,2)+pizda(2,1)
8083         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8084 #ifdef MOMENT
8085         if (swap) then
8086           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8087         else
8088           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8089         endif
8090 #endif
8091         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8092 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8093       endif
8094 C Cartesian derivatives.
8095       if (lprn) then
8096         write (2,*) 'In eello6_graph2'
8097         do iii=1,2
8098           write (2,*) 'iii=',iii
8099           do kkk=1,5
8100             write (2,*) 'kkk=',kkk
8101             do jjj=1,2
8102               write (2,'(3(2f10.5),5x)')
8103      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8104             enddo
8105           enddo
8106         enddo
8107       endif
8108       do iii=1,2
8109         do kkk=1,5
8110           do lll=1,3
8111 #ifdef MOMENT
8112             if (iii.eq.1) then
8113               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8114             else
8115               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8116             endif
8117 #endif
8118             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8119      &        auxvec(1))
8120             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8121             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8122      &        auxvec(1))
8123             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8124             call transpose2(EUg(1,1,k),auxmat(1,1))
8125             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8126      &        pizda(1,1))
8127             vv(1)=pizda(1,1)-pizda(2,2)
8128             vv(2)=pizda(1,2)+pizda(2,1)
8129             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8130 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8131 #ifdef MOMENT
8132             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8133 #else
8134             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8135 #endif
8136             if (swap) then
8137               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8138             else
8139               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8140             endif
8141           enddo
8142         enddo
8143       enddo
8144       return
8145       end
8146 c----------------------------------------------------------------------------
8147       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8148       implicit real*8 (a-h,o-z)
8149       include 'DIMENSIONS'
8150       include 'COMMON.IOUNITS'
8151       include 'COMMON.CHAIN'
8152       include 'COMMON.DERIV'
8153       include 'COMMON.INTERACT'
8154       include 'COMMON.CONTACTS'
8155       include 'COMMON.TORSION'
8156       include 'COMMON.VAR'
8157       include 'COMMON.GEO'
8158       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8159       logical swap
8160 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8161 C                                                                              C
8162 C      Parallel       Antiparallel                                             C
8163 C                                                                              C
8164 C          o             o                                                     C
8165 C         /l\   /   \   /j\                                                    C
8166 C        /   \ /     \ /   \                                                   C
8167 C       /| o |o       o| o |\                                                  C
8168 C       j|/k\|  /      |/k\|l /                                                C
8169 C        /   \ /       /   \ /                                                 C
8170 C       /     o       /     o                                                  C
8171 C       i             i                                                        C
8172 C                                                                              C
8173 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8174 C
8175 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8176 C           energy moment and not to the cluster cumulant.
8177       iti=itortyp(itype(i))
8178       if (j.lt.nres-1) then
8179         itj1=itortyp(itype(j+1))
8180       else
8181         itj1=ntortyp+1
8182       endif
8183       itk=itortyp(itype(k))
8184       itk1=itortyp(itype(k+1))
8185       if (l.lt.nres-1) then
8186         itl1=itortyp(itype(l+1))
8187       else
8188         itl1=ntortyp+1
8189       endif
8190 #ifdef MOMENT
8191       s1=dip(4,jj,i)*dip(4,kk,k)
8192 #endif
8193       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8194       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8195       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8196       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8197       call transpose2(EE(1,1,itk),auxmat(1,1))
8198       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8199       vv(1)=pizda(1,1)+pizda(2,2)
8200       vv(2)=pizda(2,1)-pizda(1,2)
8201       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8202 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8203 cd     & "sum",-(s2+s3+s4)
8204 #ifdef MOMENT
8205       eello6_graph3=-(s1+s2+s3+s4)
8206 #else
8207       eello6_graph3=-(s2+s3+s4)
8208 #endif
8209 c      eello6_graph3=-s4
8210 C Derivatives in gamma(k-1)
8211       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8212       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8213       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8214       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8215 C Derivatives in gamma(l-1)
8216       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8217       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8218       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8219       vv(1)=pizda(1,1)+pizda(2,2)
8220       vv(2)=pizda(2,1)-pizda(1,2)
8221       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8222       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8223 C Cartesian derivatives.
8224       do iii=1,2
8225         do kkk=1,5
8226           do lll=1,3
8227 #ifdef MOMENT
8228             if (iii.eq.1) then
8229               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8230             else
8231               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8232             endif
8233 #endif
8234             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8235      &        auxvec(1))
8236             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8237             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8238      &        auxvec(1))
8239             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8240             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8241      &        pizda(1,1))
8242             vv(1)=pizda(1,1)+pizda(2,2)
8243             vv(2)=pizda(2,1)-pizda(1,2)
8244             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8245 #ifdef MOMENT
8246             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8247 #else
8248             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8249 #endif
8250             if (swap) then
8251               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8252             else
8253               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8254             endif
8255 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8256           enddo
8257         enddo
8258       enddo
8259       return
8260       end
8261 c----------------------------------------------------------------------------
8262       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8263       implicit real*8 (a-h,o-z)
8264       include 'DIMENSIONS'
8265       include 'COMMON.IOUNITS'
8266       include 'COMMON.CHAIN'
8267       include 'COMMON.DERIV'
8268       include 'COMMON.INTERACT'
8269       include 'COMMON.CONTACTS'
8270       include 'COMMON.TORSION'
8271       include 'COMMON.VAR'
8272       include 'COMMON.GEO'
8273       include 'COMMON.FFIELD'
8274       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8275      & auxvec1(2),auxmat1(2,2)
8276       logical swap
8277 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8278 C                                                                              C
8279 C      Parallel       Antiparallel                                             C
8280 C                                                                              C
8281 C          o             o                                                     C
8282 C         /l\   /   \   /j\                                                    C
8283 C        /   \ /     \ /   \                                                   C
8284 C       /| o |o       o| o |\                                                  C
8285 C     \ j|/k\|      \  |/k\|l                                                  C
8286 C      \ /   \       \ /   \                                                   C
8287 C       o     \       o     \                                                  C
8288 C       i             i                                                        C
8289 C                                                                              C
8290 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8291 C
8292 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8293 C           energy moment and not to the cluster cumulant.
8294 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8295       iti=itortyp(itype(i))
8296       itj=itortyp(itype(j))
8297       if (j.lt.nres-1) then
8298         itj1=itortyp(itype(j+1))
8299       else
8300         itj1=ntortyp+1
8301       endif
8302       itk=itortyp(itype(k))
8303       if (k.lt.nres-1) then
8304         itk1=itortyp(itype(k+1))
8305       else
8306         itk1=ntortyp+1
8307       endif
8308       itl=itortyp(itype(l))
8309       if (l.lt.nres-1) then
8310         itl1=itortyp(itype(l+1))
8311       else
8312         itl1=ntortyp+1
8313       endif
8314 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8315 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8316 cd     & ' itl',itl,' itl1',itl1
8317 #ifdef MOMENT
8318       if (imat.eq.1) then
8319         s1=dip(3,jj,i)*dip(3,kk,k)
8320       else
8321         s1=dip(2,jj,j)*dip(2,kk,l)
8322       endif
8323 #endif
8324       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8325       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8326       if (j.eq.l+1) then
8327         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8328         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8329       else
8330         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8331         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8332       endif
8333       call transpose2(EUg(1,1,k),auxmat(1,1))
8334       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8335       vv(1)=pizda(1,1)-pizda(2,2)
8336       vv(2)=pizda(2,1)+pizda(1,2)
8337       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8338 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8339 #ifdef MOMENT
8340       eello6_graph4=-(s1+s2+s3+s4)
8341 #else
8342       eello6_graph4=-(s2+s3+s4)
8343 #endif
8344 C Derivatives in gamma(i-1)
8345       if (i.gt.1) then
8346 #ifdef MOMENT
8347         if (imat.eq.1) then
8348           s1=dipderg(2,jj,i)*dip(3,kk,k)
8349         else
8350           s1=dipderg(4,jj,j)*dip(2,kk,l)
8351         endif
8352 #endif
8353         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8354         if (j.eq.l+1) then
8355           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8356           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8357         else
8358           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8359           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8360         endif
8361         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8362         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8363 cd          write (2,*) 'turn6 derivatives'
8364 #ifdef MOMENT
8365           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8366 #else
8367           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8368 #endif
8369         else
8370 #ifdef MOMENT
8371           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8372 #else
8373           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8374 #endif
8375         endif
8376       endif
8377 C Derivatives in gamma(k-1)
8378 #ifdef MOMENT
8379       if (imat.eq.1) then
8380         s1=dip(3,jj,i)*dipderg(2,kk,k)
8381       else
8382         s1=dip(2,jj,j)*dipderg(4,kk,l)
8383       endif
8384 #endif
8385       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8386       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8387       if (j.eq.l+1) then
8388         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8389         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8390       else
8391         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8392         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8393       endif
8394       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8395       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8396       vv(1)=pizda(1,1)-pizda(2,2)
8397       vv(2)=pizda(2,1)+pizda(1,2)
8398       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8399       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8400 #ifdef MOMENT
8401         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8402 #else
8403         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8404 #endif
8405       else
8406 #ifdef MOMENT
8407         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8408 #else
8409         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8410 #endif
8411       endif
8412 C Derivatives in gamma(j-1) or gamma(l-1)
8413       if (l.eq.j+1 .and. l.gt.1) then
8414         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8415         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8416         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8417         vv(1)=pizda(1,1)-pizda(2,2)
8418         vv(2)=pizda(2,1)+pizda(1,2)
8419         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8420         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8421       else if (j.gt.1) then
8422         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8423         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8424         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8425         vv(1)=pizda(1,1)-pizda(2,2)
8426         vv(2)=pizda(2,1)+pizda(1,2)
8427         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8428         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8429           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8430         else
8431           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8432         endif
8433       endif
8434 C Cartesian derivatives.
8435       do iii=1,2
8436         do kkk=1,5
8437           do lll=1,3
8438 #ifdef MOMENT
8439             if (iii.eq.1) then
8440               if (imat.eq.1) then
8441                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8442               else
8443                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8444               endif
8445             else
8446               if (imat.eq.1) then
8447                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8448               else
8449                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8450               endif
8451             endif
8452 #endif
8453             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8454      &        auxvec(1))
8455             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8456             if (j.eq.l+1) then
8457               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8458      &          b1(1,itj1),auxvec(1))
8459               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8460             else
8461               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8462      &          b1(1,itl1),auxvec(1))
8463               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8464             endif
8465             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8466      &        pizda(1,1))
8467             vv(1)=pizda(1,1)-pizda(2,2)
8468             vv(2)=pizda(2,1)+pizda(1,2)
8469             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8470             if (swap) then
8471               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8472 #ifdef MOMENT
8473                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8474      &             -(s1+s2+s4)
8475 #else
8476                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8477      &             -(s2+s4)
8478 #endif
8479                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8480               else
8481 #ifdef MOMENT
8482                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8483 #else
8484                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8485 #endif
8486                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8487               endif
8488             else
8489 #ifdef MOMENT
8490               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8491 #else
8492               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8493 #endif
8494               if (l.eq.j+1) then
8495                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8496               else
8497                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8498               endif
8499             endif
8500           enddo
8501         enddo
8502       enddo
8503       return
8504       end
8505 c----------------------------------------------------------------------------
8506       double precision function eello_turn6(i,jj,kk)
8507       implicit real*8 (a-h,o-z)
8508       include 'DIMENSIONS'
8509       include 'COMMON.IOUNITS'
8510       include 'COMMON.CHAIN'
8511       include 'COMMON.DERIV'
8512       include 'COMMON.INTERACT'
8513       include 'COMMON.CONTACTS'
8514       include 'COMMON.TORSION'
8515       include 'COMMON.VAR'
8516       include 'COMMON.GEO'
8517       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8518      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8519      &  ggg1(3),ggg2(3)
8520       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8521      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8522 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8523 C           the respective energy moment and not to the cluster cumulant.
8524       s1=0.0d0
8525       s8=0.0d0
8526       s13=0.0d0
8527 c
8528       eello_turn6=0.0d0
8529       j=i+4
8530       k=i+1
8531       l=i+3
8532       iti=itortyp(itype(i))
8533       itk=itortyp(itype(k))
8534       itk1=itortyp(itype(k+1))
8535       itl=itortyp(itype(l))
8536       itj=itortyp(itype(j))
8537 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8538 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8539 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8540 cd        eello6=0.0d0
8541 cd        return
8542 cd      endif
8543 cd      write (iout,*)
8544 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8545 cd     &   ' and',k,l
8546 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8547       do iii=1,2
8548         do kkk=1,5
8549           do lll=1,3
8550             derx_turn(lll,kkk,iii)=0.0d0
8551           enddo
8552         enddo
8553       enddo
8554 cd      eij=1.0d0
8555 cd      ekl=1.0d0
8556 cd      ekont=1.0d0
8557       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8558 cd      eello6_5=0.0d0
8559 cd      write (2,*) 'eello6_5',eello6_5
8560 #ifdef MOMENT
8561       call transpose2(AEA(1,1,1),auxmat(1,1))
8562       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8563       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8564       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8565 #endif
8566       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8567       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8568       s2 = scalar2(b1(1,itk),vtemp1(1))
8569 #ifdef MOMENT
8570       call transpose2(AEA(1,1,2),atemp(1,1))
8571       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8572       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8573       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8574 #endif
8575       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8576       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8577       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8578 #ifdef MOMENT
8579       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8580       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8581       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8582       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8583       ss13 = scalar2(b1(1,itk),vtemp4(1))
8584       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8585 #endif
8586 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8587 c      s1=0.0d0
8588 c      s2=0.0d0
8589 c      s8=0.0d0
8590 c      s12=0.0d0
8591 c      s13=0.0d0
8592       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8593 C Derivatives in gamma(i+2)
8594       s1d =0.0d0
8595       s8d =0.0d0
8596 #ifdef MOMENT
8597       call transpose2(AEA(1,1,1),auxmatd(1,1))
8598       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8599       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8600       call transpose2(AEAderg(1,1,2),atempd(1,1))
8601       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8602       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8603 #endif
8604       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8605       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8606       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8607 c      s1d=0.0d0
8608 c      s2d=0.0d0
8609 c      s8d=0.0d0
8610 c      s12d=0.0d0
8611 c      s13d=0.0d0
8612       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8613 C Derivatives in gamma(i+3)
8614 #ifdef MOMENT
8615       call transpose2(AEA(1,1,1),auxmatd(1,1))
8616       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8617       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8618       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8619 #endif
8620       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8621       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8622       s2d = scalar2(b1(1,itk),vtemp1d(1))
8623 #ifdef MOMENT
8624       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8625       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8626 #endif
8627       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8628 #ifdef MOMENT
8629       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8630       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8631       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8632 #endif
8633 c      s1d=0.0d0
8634 c      s2d=0.0d0
8635 c      s8d=0.0d0
8636 c      s12d=0.0d0
8637 c      s13d=0.0d0
8638 #ifdef MOMENT
8639       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8640      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8641 #else
8642       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8643      &               -0.5d0*ekont*(s2d+s12d)
8644 #endif
8645 C Derivatives in gamma(i+4)
8646       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8647       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8648       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8649 #ifdef MOMENT
8650       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8651       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8652       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8653 #endif
8654 c      s1d=0.0d0
8655 c      s2d=0.0d0
8656 c      s8d=0.0d0
8657 C      s12d=0.0d0
8658 c      s13d=0.0d0
8659 #ifdef MOMENT
8660       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8661 #else
8662       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8663 #endif
8664 C Derivatives in gamma(i+5)
8665 #ifdef MOMENT
8666       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8667       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8668       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8669 #endif
8670       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8671       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8672       s2d = scalar2(b1(1,itk),vtemp1d(1))
8673 #ifdef MOMENT
8674       call transpose2(AEA(1,1,2),atempd(1,1))
8675       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8676       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8677 #endif
8678       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8679       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8680 #ifdef MOMENT
8681       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8682       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8683       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8684 #endif
8685 c      s1d=0.0d0
8686 c      s2d=0.0d0
8687 c      s8d=0.0d0
8688 c      s12d=0.0d0
8689 c      s13d=0.0d0
8690 #ifdef MOMENT
8691       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8692      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8693 #else
8694       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8695      &               -0.5d0*ekont*(s2d+s12d)
8696 #endif
8697 C Cartesian derivatives
8698       do iii=1,2
8699         do kkk=1,5
8700           do lll=1,3
8701 #ifdef MOMENT
8702             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8703             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8704             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8705 #endif
8706             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8707             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8708      &          vtemp1d(1))
8709             s2d = scalar2(b1(1,itk),vtemp1d(1))
8710 #ifdef MOMENT
8711             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8712             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8713             s8d = -(atempd(1,1)+atempd(2,2))*
8714      &           scalar2(cc(1,1,itl),vtemp2(1))
8715 #endif
8716             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8717      &           auxmatd(1,1))
8718             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8719             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8720 c      s1d=0.0d0
8721 c      s2d=0.0d0
8722 c      s8d=0.0d0
8723 c      s12d=0.0d0
8724 c      s13d=0.0d0
8725 #ifdef MOMENT
8726             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8727      &        - 0.5d0*(s1d+s2d)
8728 #else
8729             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8730      &        - 0.5d0*s2d
8731 #endif
8732 #ifdef MOMENT
8733             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8734      &        - 0.5d0*(s8d+s12d)
8735 #else
8736             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8737      &        - 0.5d0*s12d
8738 #endif
8739           enddo
8740         enddo
8741       enddo
8742 #ifdef MOMENT
8743       do kkk=1,5
8744         do lll=1,3
8745           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8746      &      achuj_tempd(1,1))
8747           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8748           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8749           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8750           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8751           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8752      &      vtemp4d(1))
8753           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8754           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8755           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8756         enddo
8757       enddo
8758 #endif
8759 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8760 cd     &  16*eel_turn6_num
8761 cd      goto 1112
8762       if (j.lt.nres-1) then
8763         j1=j+1
8764         j2=j-1
8765       else
8766         j1=j-1
8767         j2=j-2
8768       endif
8769       if (l.lt.nres-1) then
8770         l1=l+1
8771         l2=l-1
8772       else
8773         l1=l-1
8774         l2=l-2
8775       endif
8776       do ll=1,3
8777 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8778 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8779 cgrad        ghalf=0.5d0*ggg1(ll)
8780 cd        ghalf=0.0d0
8781         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8782         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8783         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8784      &    +ekont*derx_turn(ll,2,1)
8785         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8786         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8787      &    +ekont*derx_turn(ll,4,1)
8788         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8789         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8790         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8791 cgrad        ghalf=0.5d0*ggg2(ll)
8792 cd        ghalf=0.0d0
8793         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8794      &    +ekont*derx_turn(ll,2,2)
8795         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8796         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8797      &    +ekont*derx_turn(ll,4,2)
8798         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8799         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8800         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8801       enddo
8802 cd      goto 1112
8803 cgrad      do m=i+1,j-1
8804 cgrad        do ll=1,3
8805 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8806 cgrad        enddo
8807 cgrad      enddo
8808 cgrad      do m=k+1,l-1
8809 cgrad        do ll=1,3
8810 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8811 cgrad        enddo
8812 cgrad      enddo
8813 cgrad1112  continue
8814 cgrad      do m=i+2,j2
8815 cgrad        do ll=1,3
8816 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8817 cgrad        enddo
8818 cgrad      enddo
8819 cgrad      do m=k+2,l2
8820 cgrad        do ll=1,3
8821 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8822 cgrad        enddo
8823 cgrad      enddo
8824 cd      do iii=1,nres-3
8825 cd        write (2,*) iii,g_corr6_loc(iii)
8826 cd      enddo
8827       eello_turn6=ekont*eel_turn6
8828 cd      write (2,*) 'ekont',ekont
8829 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8830       return
8831       end
8832
8833 C-----------------------------------------------------------------------------
8834       double precision function scalar(u,v)
8835 !DIR$ INLINEALWAYS scalar
8836 #ifndef OSF
8837 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8838 #endif
8839       implicit none
8840       double precision u(3),v(3)
8841 cd      double precision sc
8842 cd      integer i
8843 cd      sc=0.0d0
8844 cd      do i=1,3
8845 cd        sc=sc+u(i)*v(i)
8846 cd      enddo
8847 cd      scalar=sc
8848
8849       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8850       return
8851       end
8852 crc-------------------------------------------------
8853       SUBROUTINE MATVEC2(A1,V1,V2)
8854 !DIR$ INLINEALWAYS MATVEC2
8855 #ifndef OSF
8856 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8857 #endif
8858       implicit real*8 (a-h,o-z)
8859       include 'DIMENSIONS'
8860       DIMENSION A1(2,2),V1(2),V2(2)
8861 c      DO 1 I=1,2
8862 c        VI=0.0
8863 c        DO 3 K=1,2
8864 c    3     VI=VI+A1(I,K)*V1(K)
8865 c        Vaux(I)=VI
8866 c    1 CONTINUE
8867
8868       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8869       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8870
8871       v2(1)=vaux1
8872       v2(2)=vaux2
8873       END
8874 C---------------------------------------
8875       SUBROUTINE MATMAT2(A1,A2,A3)
8876 #ifndef OSF
8877 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8878 #endif
8879       implicit real*8 (a-h,o-z)
8880       include 'DIMENSIONS'
8881       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8882 c      DIMENSION AI3(2,2)
8883 c        DO  J=1,2
8884 c          A3IJ=0.0
8885 c          DO K=1,2
8886 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8887 c          enddo
8888 c          A3(I,J)=A3IJ
8889 c       enddo
8890 c      enddo
8891
8892       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8893       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8894       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8895       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8896
8897       A3(1,1)=AI3_11
8898       A3(2,1)=AI3_21
8899       A3(1,2)=AI3_12
8900       A3(2,2)=AI3_22
8901       END
8902
8903 c-------------------------------------------------------------------------
8904       double precision function scalar2(u,v)
8905 !DIR$ INLINEALWAYS scalar2
8906       implicit none
8907       double precision u(2),v(2)
8908       double precision sc
8909       integer i
8910       scalar2=u(1)*v(1)+u(2)*v(2)
8911       return
8912       end
8913
8914 C-----------------------------------------------------------------------------
8915
8916       subroutine transpose2(a,at)
8917 !DIR$ INLINEALWAYS transpose2
8918 #ifndef OSF
8919 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8920 #endif
8921       implicit none
8922       double precision a(2,2),at(2,2)
8923       at(1,1)=a(1,1)
8924       at(1,2)=a(2,1)
8925       at(2,1)=a(1,2)
8926       at(2,2)=a(2,2)
8927       return
8928       end
8929 c--------------------------------------------------------------------------
8930       subroutine transpose(n,a,at)
8931       implicit none
8932       integer n,i,j
8933       double precision a(n,n),at(n,n)
8934       do i=1,n
8935         do j=1,n
8936           at(j,i)=a(i,j)
8937         enddo
8938       enddo
8939       return
8940       end
8941 C---------------------------------------------------------------------------
8942       subroutine prodmat3(a1,a2,kk,transp,prod)
8943 !DIR$ INLINEALWAYS prodmat3
8944 #ifndef OSF
8945 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8946 #endif
8947       implicit none
8948       integer i,j
8949       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8950       logical transp
8951 crc      double precision auxmat(2,2),prod_(2,2)
8952
8953       if (transp) then
8954 crc        call transpose2(kk(1,1),auxmat(1,1))
8955 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8956 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8957
8958            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8959      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8960            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8961      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8962            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8963      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8964            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8965      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8966
8967       else
8968 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8969 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8970
8971            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8972      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8973            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8974      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8975            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8976      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8977            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8978      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8979
8980       endif
8981 c      call transpose2(a2(1,1),a2t(1,1))
8982
8983 crc      print *,transp
8984 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8985 crc      print *,((prod(i,j),i=1,2),j=1,2)
8986
8987       return
8988       end
8989